From 0e79ef9676b1e92ac889bf8549d8f853d9228adb Mon Sep 17 00:00:00 2001 From: crei Date: Mon, 31 Aug 2026 23:04:41 +0200 Subject: [PATCH 1/8] Complexity theory using combinators based on fold and some other primitives. --- .../Machines/Turing/MultiTape/Complexity.lean | 55 +++ .../Turing/MultiTape/Complexity/Bounds.lean | 105 +++++ .../Turing/MultiTape/Complexity/Data.lean | 172 +++++++++ .../Turing/MultiTape/Complexity/Defs.lean | 139 +++++++ .../Turing/MultiTape/Complexity/Encoding.lean | 348 +++++++++++++++++ .../Complexity/Examples/ListIndex.lean | 231 +++++++++++ .../Complexity/Examples/ListMap.lean | 135 +++++++ .../MultiTape/Complexity/Examples/Lookup.lean | 134 +++++++ .../Complexity/Examples/NatArith.lean | 333 ++++++++++++++++ .../MultiTape/Complexity/Examples/NatMul.lean | 152 ++++++++ .../MultiTape/Complexity/Examples/Tape.lean | 219 +++++++++++ .../Complexity/Examples/Universal.lean | 365 ++++++++++++++++++ .../Turing/MultiTape/Complexity/Fold.lean | 132 +++++++ .../MultiTape/Complexity/Primitives.lean | 272 +++++++++++++ .../Turing/MultiTape/Complexity/While.lean | 102 +++++ 15 files changed, 2894 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Defs.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/While.lean diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean new file mode 100644 index 0000000000..99ab2ee88f --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean @@ -0,0 +1,55 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Data +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Encoding +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Defs +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Bounds +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.While +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListIndex +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListMap +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.NatMul +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Lookup +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Tape +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Universal +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.NatArith + +/-! +# Complexity of multi-tape Turing machines (draft) + +**STATUS: draft.** Not listed in `Cslib.lean`, because a number of statements are `sorry`-ed. They +fall into exactly two groups: + +* **Machine constructions.** `Bounds.computes` for every primitive in `Primitives.lean`, + `Bounds.fold`, `ComputableUpTo.comp` and `foldl_computableUpTo`. No concrete multi-tape Turing + machine is built anywhere in this development, so every one of these is assumed. +* **`ComputableUpTo.absorb`**, routine `Nat.pow` arithmetic (proof sketch in its docstring). + +Everything else is proved, and the split is checkable with `#print axioms`: the correctness of +each example's fold and all of the size bookkeeping come out free of `sorryAx`. + +## Layout + +| file | contents | +| --- | --- | +| `Complexity/Data.lean` | the rose-tree type, its size measure and bit encoding | +| `Complexity/Encoding.lean` | `DataEncode` and the encoded-size lemmas | +| `Complexity/Defs.lean` | `DataComputableInTimeAndSpace`, `ComputableUpTo`, `PolyTimeLinSpace` | +| `Complexity/Bounds.lean` | `Bounds`, the resource certificate, and its coarse views | +| `Complexity/Primitives.lean` | the elementary building blocks (machines assumed) | +| `Complexity/Fold.lean` | `foldl_computableUpTo` and `Bounds.fold` | +| `Complexity/While.lean` | `Bounds.while`, unbounded iteration | +| `Complexity/Examples/` | `List.map`, indexing, `Nat` arithmetic, lookup, a universal machine | + +## References + +* [issue #611, *Plan for complexity theory*](https://github.com/leanprover/cslib/issues/611) +* [issue #590, *Framework for encoding arbitrary types on Turing machines*](https://github.com/leanprover/cslib/issues/590) +-/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean new file mode 100644 index 0000000000..6bc8f4ff48 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean @@ -0,0 +1,105 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Defs + +/-! +# Resource certificates + +`Bounds f` bundles everything a combinator needs to know about `f`: a time bound, a work-tape +space bound, a bound on the size of its output, the monotonicity of all three, and the proofs that +they hold. Combinators then become *definitions that compute bounds* rather than theorems that +restate them, and their monotonicity side conditions discharge themselves. + +## Design + +* **Indexed by the function.** `Bounds f`, not a structure with an `fn` field, so that one can + state `Bounds Nat.succ` and keep the function visible in the type. +* **Built on `DataComputableInTimeAndSpace`, not `ComputableUpTo`.** The coarse view discards + polynomial factors in time and constant factors in space *at the point of statement*; an algebra + built on top of it could never recover them. `Bounds.polyTimeLinSpace` takes the coarse view at + the very end instead. +* **`outSize` is a field of its own.** It is not derivable from `space`: the output tape is + write-only and is not charged for space, so a machine may emit far more than its work-tape + space. (`outSize ≤ time` is always available — at most one symbol is emitted per step — but it is + usually far too weak.) +* `Bounds` is `Type`-valued: it is a witness, not a property. Use `ComputableUpTo` when a `Prop` is + wanted. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +variable {α β : Type} [DataEncode α] [DataEncode β] + +/-- A resource certificate for `f`: bounds on its running time, its work-tape space and the size +of its output, all as functions of the encoded input size, together with their monotonicity and +the proofs that they hold. -/ +structure Bounds (f : α → β) where + /-- Bound on the number of steps, in the encoded input size. -/ + time : ℕ → ℕ + /-- Bound on the number of work-tape cells visited, in the encoded input size. -/ + space : ℕ → ℕ + /-- Bound on the encoded size of the output, in the encoded input size. -/ + outSize : ℕ → ℕ + /-- Combinators evaluate `time` at an over-approximation of the true input size. -/ + time_mono : Monotone time + /-- Combinators evaluate `space` at an over-approximation of the true input size. -/ + space_mono : Monotone space + /-- Combinators evaluate `outSize` at an over-approximation of the true input size. -/ + outSize_mono : Monotone outSize + /-- Some multi-tape Turing machine computes `f` within `time` and `space`. -/ + computes : DataComputableInTimeAndSpace f time space + /-- The output really is no bigger than `outSize` says. -/ + out_le : ∀ a, (DataEncode.encode (f a)).size ≤ outSize (DataEncode.encode a).size + +namespace Bounds + +/-- Transport a certificate along an equality of functions. Used to turn a certificate for the +literal shape a combinator produces into one for the function actually of interest. -/ +def congr {f g : α → β} (b : Bounds f) (h : f = g) : Bounds g := h ▸ b + +/-- Weaken all three bounds at once. Composition produces one specific closed form; this is how +one restates it more readably. -/ +def weaken {f : α → β} (b : Bounds f) (t s o : ℕ → ℕ) + (ht_mono : Monotone t) (hs_mono : Monotone s) (ho_mono : Monotone o) + (ht : ∀ n, b.time n ≤ t n) (hs : ∀ n, b.space n ≤ s n) (ho : ∀ n, b.outSize n ≤ o n) : + Bounds f where + time := t + space := s + outSize := o + time_mono := ht_mono + space_mono := hs_mono + outSize_mono := ho_mono + computes := b.computes.mono ht hs + out_le a := le_trans (b.out_le a) (ho _) + +/-- Every certificate yields the coarse `ComputableUpTo` statement with the same bounds. -/ +theorem toComputableUpTo {f : α → β} (b : Bounds f) : ComputableUpTo f b.time b.space := + ⟨1, b.computes.mono + (fun n => by simp only [pow_one, one_mul]; omega) + (fun n => by simp only [one_mul]; omega)⟩ + +/-- Read "polynomial time, linear space" off a certificate. This is the intended last step of an +example: build the certificate with exact bounds, then take the coarse view once. -/ +theorem polyTimeLinSpace {f : α → β} (b : Bounds f) (d k e : ℕ) + (ht : ∀ n, b.time n ≤ d * (n + n + 2) ^ k) + (hs : ∀ n, b.space n ≤ e * (n + 1)) : + PolyTimeLinSpace f := + b.toComputableUpTo.absorb d k e ht hs + +end Bounds + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean new file mode 100644 index 0000000000..a329054099 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Init +public import Mathlib.Tactic.Ring +public import Mathlib.Algebra.Order.BigOperators.Group.List + +/-! +# The rose-tree data type + +The single universal data type into which everything put on a Turing machine tape is encoded, +together with its size measure, its balanced-parenthesis bit encoding, and a handful of +list-sum helpers that the size lemmas downstream are built from. + +Reproduced from the `roseTreeMachine` branch of the `crei/cslib` fork; see +[issue #611](https://github.com/leanprover/cslib/issues/611). Part of the draft complexity +development rooted at `Complexity.lean`. +-/ + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +/-! ## 1. The rose-tree data type + +Reproduced from the `roseTreeMachine` branch of `crei/cslib`; see the TODO above. +-/ + +/-- The rose-tree data type: the single universal data type into which we encode everything that +is put on a tape. It is expressive enough to mirror most Lean data types in a natural way, and it +supports a `fold` operation, which is the subject of this file. -/ +inductive Data where + /-- A node with the given children. -/ + | l : List Data → Data + deriving Repr + +/-- The children of a node. -/ +def Data.asList : Data → List Data + | Data.l xs => xs + +/-- The empty rose tree. -/ +abbrev Data.empty : Data := Data.l [] + +/-- The size of a rose tree, which is by construction exactly the length of its encoding +`Data.toBits` as a bit string: one bit for the opening and one for the closing parenthesis of +every node. This is *the* notion of input size used throughout this file. -/ +def Data.size : Data → ℕ + | Data.l xs => 2 + (xs.map Data.size).sum + +/-- The nesting depth of a rose tree. Bounding this by a constant of the type is what lets a +machine skip over a subtree in constant work-tape space; see `DataEncode`. -/ +def Data.depth : Data → ℕ + | Data.l xs => 1 + (xs.map Data.depth).foldr max 0 + +/-- A uniform bound on the elements bounds a `foldr max`. -/ +lemma foldr_max_le {α : Type} (xs : List α) (f : α → ℕ) (d : ℕ) + (h : ∀ x ∈ xs, f x ≤ d) : (xs.map f).foldr max 0 ≤ d := by + induction xs with + | nil => simp + | cons y ys ih => + have hy := h y (by simp) + have hrest := ih fun x hx => h x (by simp [hx]) + simp only [List.map_cons, List.foldr_cons] + omega + +/-- Every rose tree costs at least the two bits of its root node. -/ +lemma Data.two_le_size (d : Data) : 2 ≤ d.size := by + cases d with + | l xs => simp [Data.size] + +mutual + +/-- The canonical balanced-parenthesis encoding of a rose tree as a bit string: `false` opens a +node, `true` closes it. This is what is actually written on a Turing machine tape. -/ +def Data.toBits : Data → List Bool + | Data.l xs => false :: (Data.listToBits xs ++ [true]) + +/-- Auxiliary for `Data.toBits`: the concatenated encodings of a list of children. -/ +def Data.listToBits : List Data → List Bool + | [] => [] + | x :: xs => Data.toBits x ++ Data.listToBits xs + +end + +mutual + +/-- `Data.size` is exactly the length of the bit encoding. This is the only reason `Data.size` +is defined with the constant `2`, and it is what lets us state all bounds in terms of `size` +while the machines actually operate on `Data.toBits`. -/ +lemma Data.length_toBits (d : Data) : d.toBits.length = d.size := by + cases d with + | l xs => + simp [Data.toBits, Data.size, Data.length_listToBits xs] + omega + +/-- Auxiliary for `Data.length_toBits`. -/ +lemma Data.length_listToBits (xs : List Data) : + (Data.listToBits xs).length = (xs.map Data.size).sum := by + cases xs with + | nil => simp [Data.listToBits] + | cons x xs => + simp [Data.listToBits, Data.length_toBits x, Data.length_listToBits xs] + +end + +/-! ### List helpers + +Two arithmetic helpers about sums of mapped lists, used only to compute encoded sizes. +-/ + +/-- A uniform bound on the elements bounds the sum of a mapped list. -/ +lemma sum_map_le {α : Type} (xs : List α) (f : α → ℕ) (b : ℕ) + (h : ∀ x ∈ xs, f x ≤ b) : (xs.map f).sum ≤ b * xs.length := by + induction xs with + | nil => simp + | cons y ys ih => + have hy := h y (by simp) + have hys := ih fun x hx => h x (by simp [hx]) + have hb : b * (ys.length + 1) = b * ys.length + b := by ring + simp only [List.map_cons, List.sum_cons, List.length_cons] + omega + +/-- A uniform lower bound on the elements bounds the sum of a mapped list from below. -/ +lemma le_sum_map {α : Type} (xs : List α) (f : α → ℕ) (b : ℕ) + (h : ∀ x ∈ xs, b ≤ f x) : b * xs.length ≤ (xs.map f).sum := by + induction xs with + | nil => simp + | cons y ys ih => + have hy := h y (by simp) + have hys := ih fun x hx => h x (by simp [hx]) + have hb : b * (ys.length + 1) = b * ys.length + b := by ring + simp only [List.map_cons, List.sum_cons, List.length_cons] + omega + +/-- If the mapped function is constant, the sum is that constant times the length. -/ +lemma sum_map_const {α : Type} (xs : List α) (f : α → ℕ) (b : ℕ) + (h : ∀ x, f x = b) : (xs.map f).sum = b * xs.length := by + induction xs with + | nil => simp + | cons y ys ih => + simp only [List.map_cons, List.sum_cons, List.length_cons, ih, h y] + ring + +/-- A pointwise bound `f x ≤ c * g x` lifts to the sums of the mapped lists. -/ +lemma sum_map_le_of_le {α : Type} (l : List α) (f g : α → ℕ) (c : ℕ) + (h : ∀ x ∈ l, f x ≤ c * g x) : (l.map f).sum ≤ c * (l.map g).sum := by + induction l with + | nil => simp + | cons y ys ih => + have hy := h y (by simp) + have hrest := ih fun x hx => h x (by simp [hx]) + have hmul : c * (g y + (ys.map g).sum) = c * g y + c * (ys.map g).sum := by ring + simp only [List.map_cons, List.sum_cons] + omega + +/-- Summing over a prefix is bounded by summing over the whole list. -/ +lemma sum_map_take_le {α : Type} (l : List α) (f : α → ℕ) (j : ℕ) : + ((l.take j).map f).sum ≤ (l.map f).sum := by + conv_rhs => rw [← List.take_append_drop j l] + rw [List.map_append, List.sum_append] + omega + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Defs.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Defs.lean new file mode 100644 index 0000000000..057be0c616 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Defs.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Encoding +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic +public import Mathlib.Order.Monotone.Defs +public import Mathlib.Tactic.Linarith + +/-! +# Computability of typed functions + +`DataComputableInTimeAndSpace` lifts `MultiTapeTM.ComputableInTimeAndSpace` to functions between +arbitrary encodable types, measuring resources in the *encoded* input size. `ComputableUpTo` is the +coarse view of it — polynomial slack in time, constant-factor slack in space — and +`PolyTimeLinSpace` is the coarse view most statements are phrased with. + +Prefer the precise `DataComputableInTimeAndSpace` (via `Bounds`) when building an algebra of +combinators: `ComputableUpTo` destroys exactly the precision that sub-linear-space results need. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +/-! ## 3. Computability of typed functions, up to polynomial time and linear space + +`MultiTapeTM.ComputableInTimeAndSpace` speaks about functions `List IOSymbol → List IOSymbol` +and measures resources in the raw input length. `DataComputableInTimeAndSpace` lifts it to +functions between arbitrary encodable types, measuring resources in the *encoded* input size. + +Note that the machine is only constrained on inputs that are genuine encodings; bit strings that +do not decode to a value of `α` are left completely unspecified. That is why `DataEncode` needs +no decoding function: requiring the machine to also *recognise* malformed inputs within the same +bounds would be a strictly stronger — and, for the purposes of this file, irrelevant — demand. +-/ + +/-- The typed analogue of `MultiTapeTM.ComputableInTimeAndSpace`: there is a multi-tape Turing +machine with a finite alphabet and a finite state set that, on the encoding of any `a : α`, +outputs the encoding of `f a` using at most `t n` steps and at most `s n` cells, where `n` is the +encoded size of `a`. -/ +def DataComputableInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] + (f : α → β) (t s : ℕ → ℕ) : Prop := + ∃ (k sym state : ℕ) (emb : Bool ↪ Fin sym) (tm : MultiTapeTM k (Fin sym) (Fin state)), + ∀ a : α, + ∃ t' ≤ t (DataEncode.encode a).size, ∃ s' ≤ s (DataEncode.encode a).size, + tm.ComputesInTimeAndSpace + ((DataEncode.encode a).toBits.map emb) + ((DataEncode.encode (f a)).toBits.map emb) + t' s' + +/-- Weakening the bounds of `DataComputableInTimeAndSpace`. -/ +lemma DataComputableInTimeAndSpace.mono {α β : Type} [DataEncode α] [DataEncode β] + {f : α → β} {t s t' s' : ℕ → ℕ} + (h : DataComputableInTimeAndSpace f t s) + (ht : ∀ n, t n ≤ t' n) (hs : ∀ n, s n ≤ s' n) : + DataComputableInTimeAndSpace f t' s' := by + obtain ⟨k, sym, state, emb, tm, h⟩ := h + refine ⟨k, sym, state, emb, tm, fun a => ?_⟩ + obtain ⟨t₀, ht₀, s₀, hs₀, hcomp⟩ := h a + exact ⟨t₀, le_trans ht₀ (ht _), s₀, le_trans hs₀ (hs _), hcomp⟩ + +/-- The main notion of this file: `f` is computable in time *polynomially* bounded in `t` and +space bounded in `s` *up to a constant factor*. + +This is the level of precision at which composition theorems such as `foldl_computableUpTo` are +stated: it is coarse enough that no particular tape layout, alphabet or head-scheduling discipline +can matter, and it is closed under composition (a polynomial in a polynomial is a polynomial; a +constant multiple of a constant multiple is a constant multiple), so such statements chain. + +The `+ n + 2` in the time bound simply acknowledges that a machine must be allowed to read its +input; it makes the notion insensitive to time bounds that are sublinear for trivial reasons. -/ +def ComputableUpTo {α β : Type} [DataEncode α] [DataEncode β] + (f : α → β) (t s : ℕ → ℕ) : Prop := + ∃ c : ℕ, DataComputableInTimeAndSpace f + (fun n => c * (t n + n + 2) ^ c) + (fun n => c * (s n + 1)) + +/-- `f` is computable in polynomial time and linear space. -/ +abbrev PolyTimeLinSpace {α β : Type} [DataEncode α] [DataEncode β] (f : α → β) : Prop := + ComputableUpTo f (fun n => n) (fun n => n) + +/-- Weakening the bounds of `ComputableUpTo`. -/ +lemma ComputableUpTo.mono {α β : Type} [DataEncode α] [DataEncode β] + {f : α → β} {t s t' s' : ℕ → ℕ} + (h : ComputableUpTo f t s) (ht : ∀ n, t n ≤ t' n) (hs : ∀ n, s n ≤ s' n) : + ComputableUpTo f t' s' := by + obtain ⟨c, hc⟩ := h + refine ⟨c, hc.mono (fun n => ?_) (fun n => ?_)⟩ + · exact Nat.mul_le_mul_left _ (Nat.pow_le_pow_left (by have := ht n; omega) _) + · exact Nat.mul_le_mul_left _ (by have := hs n; omega) + +/-- `ComputableUpTo` absorbs its own slack: a bound that is polynomially related to `t'` and +linearly related to `s'` may be *restated* as a bound in terms of `t'` and `s'`. + +This is what lets a caller state a clean conclusion — "polynomial time, linear space" — after a +chain of compositions has produced an unwieldy closed form. + +Proof sketch (routine `Nat.pow` arithmetic, still to be written): from `h` obtain `c`. Since +`t n + n + 2 ≤ d * (t' n + n + 2) ^ d + (t' n + n + 2) ≤ (d + 1) * (t' n + n + 2) ^ (max d 1)`, +one gets `c * (t n + n + 2) ^ c ≤ c * (d + 1) ^ c * (t' n + n + 2) ^ (c * max d 1)`; as the base +is at least `2`, any `c'` above both `c * (d + 1) ^ c` and `c * max d 1` works. For space, +`c * (s n + 1) ≤ c * (e * (s' n + 1) + 1) ≤ c * (e + 1) * (s' n + 1)`. Take the max of the two +witnesses. -/ +lemma ComputableUpTo.absorb {α β : Type} [DataEncode α] [DataEncode β] + {f : α → β} {t s t' s' : ℕ → ℕ} (d k e : ℕ) + (h : ComputableUpTo f t s) + (ht : ∀ n, t n ≤ d * (t' n + n + 2) ^ k) + (hs : ∀ n, s n ≤ e * (s' n + 1)) : + ComputableUpTo f t' s' := by + sorry + +/-- **Sequential composition.** Run the machine for `f`, materialise its output on a work tape, +then run the machine for `g` on it. + +`S_f` bounds the encoded size of `f`'s output, which is both the argument size at which `g`'s +bounds have to be evaluated and the amount of tape the intermediate result occupies — hence its +appearance in the space bound. -/ +lemma ComputableUpTo.comp {α β γ : Type} [DataEncode α] [DataEncode β] [DataEncode γ] + {f : α → β} {g : β → γ} {t_f s_f t_g s_g S_f : ℕ → ℕ} + (hf : ComputableUpTo f t_f s_f) (hg : ComputableUpTo g t_g s_g) + (h_t_g : Monotone t_g) (h_s_g : Monotone s_g) + (h_out : ∀ a, (DataEncode.encode (f a)).size ≤ S_f (DataEncode.encode a).size) : + ComputableUpTo (g ∘ f) + (fun n => t_f n + t_g (S_f n)) + (fun n => s_f n + s_g (S_f n) + S_f n) := by + sorry + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean new file mode 100644 index 0000000000..2843e8cd13 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean @@ -0,0 +1,348 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Data +public import Mathlib.Data.Nat.Size + +/-! +# Encoding Lean types into rose trees + +`DataEncode α` injects `α` into `Data`; the instances are compositional, so the encoded size of a +structured value decomposes into the sizes of its parts. Those decomposition lemmas are what every +complexity proof downstream reasons with — nothing after this file should need to unfold +`DataEncode.encode` or `Data.size` again. +-/ + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +/-! ## 2. Encoding Lean types into rose trees -/ + +/-- An encoding of the type `α` into rose trees. + +Injectivity is required, but no decoding function and no round-trip property: a machine is always +handed the encoding of an actual value of `α` (see the discussion of +`DataComputableInTimeAndSpace`). + +The `depth` bound is **not** cosmetic. The structural primitives — `Bounds.fst`, `Bounds.snd`, +`Bounds.headD`, `Bounds.tail` — claim to use *no work tape at all*. Each of them has to skip over a +subtree to find its matching close bracket, which a machine does by scanning while counting +nesting depth. That counter is free only if the depth it can reach is bounded by a constant of the +type; if encodings could be arbitrarily deep the counter would grow with the input and those +`space := 0` claims would be false. + +This is exactly why there is no `DataEncode Data` instance: encoding `Data` as itself admits trees +of unbounded depth, so it would silently invalidate every primitive. Every instance below is +shallow — a list of `α` is one level deeper than `α`, and so on. -/ +class DataEncode (α : Type) where + /-- The encoding function. -/ + encode : α → Data + /-- Distinct values have distinct encodings. -/ + h_inj : Function.Injective encode + /-- A bound on the nesting depth of encodings, depending on `α` alone. -/ + depth : ℕ + /-- Encodings really are that shallow. -/ + h_depth : ∀ a, (encode a).depth ≤ depth + +instance : DataEncode Bool where + encode b := if b then Data.l [Data.l []] else Data.l [] + h_inj := by intro a b h; cases a <;> cases b <;> simp_all + depth := 2 + h_depth b := by + cases b + · change (Data.l ([] : List Data)).depth ≤ 2 + simp [Data.depth] + · change (Data.l [Data.l []]).depth ≤ 2 + simp [Data.depth] + +instance : DataEncode Unit where + encode _ := Data.l [] + h_inj := fun a b _ => Subsingleton.elim a b + depth := 1 + h_depth _ := by + simp [Data.depth] + +@[simp] +lemma DataEncode.size_unit (u : Unit) : (DataEncode.encode u).size = 2 := by + cases u + change (Data.l []).size = 2 + simp [Data.size] + +instance (α : Type) [DataEncode α] : DataEncode (List α) where + encode xs := Data.l (xs.map DataEncode.encode) + h_inj := by + intro a b h + exact List.map_injective_iff.mpr DataEncode.h_inj (Data.l.inj h) + depth := 1 + DataEncode.depth (α := α) + h_depth xs := by + rw [Data.depth, List.map_map] + have := foldr_max_le xs (Data.depth ∘ DataEncode.encode) (DataEncode.depth (α := α)) + (fun x _ => DataEncode.h_depth x) + omega + +instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where + encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b] + h_inj := by + intro p q h + obtain ⟨a₁, b₁⟩ := p + obtain ⟨a₂, b₂⟩ := q + simp only [Data.l.injEq, List.cons.injEq, and_true] at h + simp [DataEncode.h_inj h.1, DataEncode.h_inj h.2] + depth := 1 + max (DataEncode.depth (α := α)) (DataEncode.depth (α := β)) + h_depth p := by + obtain ⟨a, b⟩ := p + change (Data.l [DataEncode.encode a, DataEncode.encode b]).depth ≤ _ + have h1 := DataEncode.h_depth a + have h2 := DataEncode.h_depth b + rw [Data.depth] + simp only [List.map_cons, List.map_nil, List.foldr_cons, List.foldr_nil] + omega + +instance (α : Type) [DataEncode α] : DataEncode (Option α) where + encode + | none => Data.l [] + | some x => Data.l [DataEncode.encode x] + h_inj := by + intro a b h + cases a <;> cases b <;> simp_all [DataEncode.h_inj.eq_iff] + depth := 1 + DataEncode.depth (α := α) + h_depth o := by + cases o with + | none => + change (Data.l ([] : List Data)).depth ≤ _ + simp [Data.depth] + | some x => + change (Data.l [DataEncode.encode x]).depth ≤ _ + have := DataEncode.h_depth x + rw [Data.depth] + simp only [List.map_cons, List.map_nil, List.foldr_cons, List.foldr_nil] + omega + +/-- One node per bit of a natural number. + +The two bit values are deliberately encoded by *different trees of the same size*, so that +`(DataEncode.encode n).size` depends only on the number of bits of `n` and is therefore +**monotone in `n`** (`DataEncode.size_nat_mono`). Routing `ℕ` through `DataEncode (List Bool)` +instead would not be monotone, because `encode true` and `encode false` have different sizes: +`(encode 7).size > (encode 8).size`, which makes every size-bookkeeping argument about counters +unnecessarily painful. The price is a constant factor, which none of the statements here can +observe. -/ +def Data.ofBit (b : Bool) : Data := + if b then Data.l [Data.l [], Data.l []] else Data.l [Data.l [Data.l []]] + +@[simp] +lemma Data.size_ofBit (b : Bool) : (Data.ofBit b).size = 6 := by + cases b <;> simp [Data.ofBit, Data.size] + +/-- Read a little-endian bit list back as a natural number. This is a left inverse of +`Nat.bits` (`natOfBits_bits`), which is what makes `Nat.bits` injective, and it is the +"read the answer off the tape" step of the arithmetic examples. -/ +def natOfBits (bs : List Bool) : ℕ := bs.foldr (fun b acc => Nat.bit b acc) 0 + +@[simp] +lemma natOfBits_nil : natOfBits [] = 0 := rfl + +@[simp] +lemma natOfBits_cons (b : Bool) (bs : List Bool) : + natOfBits (b :: bs) = Nat.bit b (natOfBits bs) := rfl + +/-- `Nat.bit` in arithmetic form. -/ +lemma Nat.bit_eq_two_mul_add (b : Bool) (n : ℕ) : + Nat.bit b n = 2 * n + cond b 1 0 := by + cases b <;> simp [Nat.bit] + +/-- Appending trailing zeros does not change the value of a bit list. -/ +@[simp] +lemma natOfBits_append_replicate_false (bs : List Bool) (k : ℕ) : + natOfBits (bs ++ List.replicate k false) = natOfBits bs := by + induction bs with + | nil => + simp only [List.nil_append] + induction k with + | zero => simp + | succ k ih => simp [List.replicate_succ, ih, Nat.bit_eq_two_mul_add] + | cons b bs ih => simp [ih] + +/-- A bit list of length `k` denotes a number below `2 ^ k`. -/ +lemma natOfBits_lt (bs : List Bool) : natOfBits bs < 2 ^ bs.length := by + induction bs with + | nil => simp + | cons b bs ih => + simp only [natOfBits_cons, Nat.bit_eq_two_mul_add, List.length_cons, pow_succ] + cases b <;> simp <;> omega + +/-- Multiplying adds at most the two bit lengths. -/ +lemma Nat.size_mul_le (a b : ℕ) : (a * b).size ≤ a.size + b.size := by + rw [Nat.size_le, pow_add] + exact Nat.mul_lt_mul_of_lt_of_lt (Nat.lt_size_self a) (Nat.lt_size_self b) + +/-- A power of two has bit length one more than its exponent. -/ +lemma Nat.size_two_pow_le (j : ℕ) : (2 ^ j).size ≤ j + 1 := by + rw [Nat.size_le] + exact Nat.pow_lt_pow_right (by omega) (by omega) + +/-- `natOfBits` is a left inverse of `Nat.bits`. -/ +lemma natOfBits_bits (n : ℕ) : natOfBits n.bits = n := by + induction n using Nat.binaryRec' with + | zero => simp + | bit b n hn ih => rw [Nat.bits_append_bit n b hn]; simp [ih] + +lemma Data.ofBit_injective : Function.Injective Data.ofBit := by + intro x y h + cases x <;> cases y <;> simp_all [Data.ofBit] + +instance : DataEncode ℕ where + encode n := Data.l (n.bits.map Data.ofBit) + h_inj := by + intro a b h + have hb : a.bits = b.bits := + List.map_injective_iff.mpr Data.ofBit_injective (Data.l.inj h) + -- `Nat.bits` has a left inverse (`natOfBits`), hence is injective. + rw [← natOfBits_bits a, ← natOfBits_bits b, hb] + depth := 4 + h_depth n := by + rw [Data.depth, List.map_map] + have hb : ∀ b : Bool, (Data.depth ∘ Data.ofBit) b ≤ 3 := by + intro b + cases b <;> simp [Data.ofBit, Data.depth] + have := foldr_max_le n.bits (Data.depth ∘ Data.ofBit) 3 (fun b _ => hb b) + omega + +/-! ### Encoded sizes + +The size lemmas below are what complexity proofs actually reason with; nothing downstream should +need to unfold `DataEncode.encode` or `Data.size` again. +-/ + +/-- The encoded size of a list is two (for the node itself) plus the encoded sizes of its +elements. -/ +lemma DataEncode.size_list {α : Type} [DataEncode α] (xs : List α) : + (DataEncode.encode xs).size = 2 + (xs.map fun x => (DataEncode.encode x).size).sum := by + change (Data.l (xs.map DataEncode.encode)).size = _ + simp [Data.size, List.map_map, Function.comp_def] + +/-- The encoded size of a pair is the sum of the encoded sizes plus the two parentheses of the +pair node itself. This is the size at which the bounds of `step` have to be evaluated. -/ +lemma DataEncode.size_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) : + (DataEncode.encode (a, b)).size = + (DataEncode.encode a).size + (DataEncode.encode b).size + 2 := by + change (Data.l [DataEncode.encode a, DataEncode.encode b]).size = _ + simp [Data.size] + omega + +/-- A cons cell costs exactly the sum of its parts: the list node's own two cells are already +paid for by the encoding of the tail. Equivalently, it is two cells cheaper than the pair +`(x, xs)` it is built from — consing deletes one bracket. -/ +lemma DataEncode.size_cons {α : Type} [DataEncode α] (x : α) (xs : List α) : + (DataEncode.encode (x :: xs)).size + = (DataEncode.encode x).size + (DataEncode.encode xs).size := by + rw [DataEncode.size_list, DataEncode.size_list] + simp only [List.map_cons, List.sum_cons] + omega + +@[simp] +lemma DataEncode.size_none {α : Type} [DataEncode α] : + (DataEncode.encode (none : Option α)).size = 2 := by + change (Data.l []).size = 2 + simp [Data.size] + +@[simp] +lemma DataEncode.size_some {α : Type} [DataEncode α] (x : α) : + (DataEncode.encode (some x)).size = (DataEncode.encode x).size + 2 := by + change (Data.l [DataEncode.encode x]).size = _ + simp [Data.size] + omega + +/-- Dropping the head never grows the encoding. -/ +lemma DataEncode.size_tail_le {α : Type} [DataEncode α] (xs : List α) : + (DataEncode.encode xs.tail).size ≤ (DataEncode.encode xs).size := by + cases xs with + | nil => simp + | cons x xs => + have h := DataEncode.size_cons x xs + have h2 := Data.two_le_size (DataEncode.encode x) + simpa using by omega + +/-- Every element of a list is a subtree of the encoding of that list, so its encoded size is +bounded by the encoded size of the list. -/ +lemma DataEncode.size_mem_le {α : Type} [DataEncode α] {xs : List α} {x : α} (h : x ∈ xs) : + (DataEncode.encode x).size ≤ (DataEncode.encode xs).size := by + have hle : (DataEncode.encode x).size ≤ (xs.map fun y => (DataEncode.encode y).size).sum := + List.single_le_sum (fun _ _ => Nat.zero_le _) _ (List.mem_map_of_mem h) + rw [DataEncode.size_list] + omega + +/-- Every element of a list contributes at least two to the encoded size of the list, so the +length of a list is bounded by its encoded size. This is what bounds the number of iterations +of a fold. -/ +lemma DataEncode.length_le_size {α : Type} [DataEncode α] (xs : List α) : + xs.length ≤ (DataEncode.encode xs).size := by + have h := le_sum_map xs (fun x => (DataEncode.encode x).size) 2 + (fun x _ => Data.two_le_size _) + rw [DataEncode.size_list] + omega + +/-- A uniform bound on the encoded sizes of the elements bounds the encoded size of the list. -/ +lemma DataEncode.size_list_le {α : Type} [DataEncode α] (xs : List α) (b : ℕ) + (h : ∀ x ∈ xs, (DataEncode.encode x).size ≤ b) : + (DataEncode.encode xs).size ≤ 2 + b * xs.length := by + have := sum_map_le xs (fun x => (DataEncode.encode x).size) b h + rw [DataEncode.size_list] + omega + +@[simp] +lemma DataEncode.size_bool (b : Bool) : (DataEncode.encode b).size ≤ 4 := by + cases b <;> change (Data.l _).size ≤ 4 <;> simp [Data.size] + +/-- A bit list occupies at most `2 + 4 * length` cells. -/ +lemma DataEncode.size_bits_le (bs : List Bool) : + (DataEncode.encode bs).size ≤ 2 + 4 * bs.length := + DataEncode.size_list_le bs 4 (fun b _ => DataEncode.size_bool b) + +/-- The encoded size of a natural number is determined by its bit length. -/ +lemma DataEncode.size_nat (n : ℕ) : (DataEncode.encode n).size = 2 + 6 * n.size := by + have hsz : (Data.l (n.bits.map Data.ofBit)).size + = 2 + ((n.bits.map Data.ofBit).map Data.size).sum := by + simp [Data.size] + change (Data.l (n.bits.map Data.ofBit)).size = _ + rw [hsz, List.map_map, + sum_map_const n.bits (Data.size ∘ Data.ofBit) 6 (fun b => Data.size_ofBit b), + Nat.size_eq_bits_len] + +/-- The bit length of a natural number is bounded by its encoded size. -/ +lemma DataEncode.bits_length_le (n : ℕ) : n.bits.length ≤ (DataEncode.encode n).size := by + rw [DataEncode.size_nat, Nat.size_eq_bits_len] + omega + +/-- The encoded size of a natural number is monotone. This is the whole point of `Data.ofBit`. -/ +lemma DataEncode.size_nat_mono {m n : ℕ} (h : m ≤ n) : + (DataEncode.encode m).size ≤ (DataEncode.encode n).size := by + have := Nat.size_le_size h + rw [DataEncode.size_nat, DataEncode.size_nat] + omega + +private lemma natSize_succ_le (i : ℕ) : (i + 1).size ≤ i.size + 1 := by + rw [Nat.size_le, pow_succ] + have h : i < 2 ^ i.size := Nat.lt_size_self i + have h2 : 0 < 2 ^ i.size := Nat.two_pow_pos i.size + generalize 2 ^ i.size = X at h h2 ⊢ + omega + +/-- Incrementing a natural number costs at most one extra node in the encoding. -/ +lemma DataEncode.size_nat_succ (i : ℕ) : + (DataEncode.encode (i + 1)).size ≤ (DataEncode.encode i).size + 6 := by + have := natSize_succ_le i + rw [DataEncode.size_nat, DataEncode.size_nat] + omega + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean new file mode 100644 index 0000000000..9d9a8571a0 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold + +/-! +# Example: `fun (i, l) => l[i]?` +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +/-! ## 5. Worked example: `fun (i, l) => l[i]?` + +Indexing is a fold: walk the list carrying a countdown and the element found so far. + +The counter is stored *offset by one* — `init` produces `i + 1`, and the element is picked up when +the counter reads `1`. That offset is what makes the fold stop writing: truncated subtraction pins +the counter at `0`, which the guard never matches again, so later elements cannot overwrite the +answer. Storing `i` itself and grabbing at `0` would re-grab on every subsequent element. + +The final accumulator is a pair, so the answer is extracted with `Prod.snd`; that is what forces +`ComputableUpTo.comp` into the picture. It is worth noting that the fold theorem *alone* is not +enough to state a complexity result for a function as simple as list indexing — a composition +principle is needed as well. +-/ + +namespace ListIndex + +variable {α : Type} + +/-- The list the indexing fold runs over: the list component of the input. -/ +def listFn (p : ℕ × List α) : List α := p.2 + +/-- The initial accumulator: the index, offset by one, and "nothing found yet". -/ +def initFn (p : ℕ × List α) : ℕ × Option α := (p.1 + 1, none) + +/-- One step of the indexing fold: count down, and pick up the element exactly when the counter +reads `1`. -/ +def stepFn (acc : ℕ × Option α) (x : α) : ℕ × Option α := + (acc.1 - 1, if acc.1 = 1 then some x else acc.2) + +/-! ### Correctness of the fold -/ + +/-- Once the counter has reached `0` the accumulator is frozen: truncated subtraction keeps it at +`0`, and the guard `acc.1 = 1` never fires again. -/ +lemma foldl_zero (l : List α) (r : Option α) : + l.foldl stepFn (0, r) = (0, r) := by + induction l generalizing r with + | nil => rfl + | cons x xs ih => simpa [stepFn] using ih r + +/-- Past the end of the list the fold returns the accumulator it started with. -/ +lemma foldl_snd_of_ge (l : List α) (i : ℕ) (r : Option α) (h : l.length ≤ i) : + (l.foldl stepFn (i + 1, r)).2 = r := by + induction l generalizing i r with + | nil => simp + | cons x xs ih => + rw [List.length_cons] at h + obtain ⟨k, rfl⟩ : ∃ k, i = k + 1 := ⟨i - 1, by omega⟩ + rw [List.foldl_cons] + change (xs.foldl stepFn (k + 1 + 1 - 1, if k + 1 + 1 = 1 then some x else r)).2 = r + rw [ite_eq_right (by omega), show k + 1 + 1 - 1 = k + 1 from by omega] + exact ih k r (by omega) + +/-- Within the list the fold returns the element at the index. -/ +lemma foldl_snd_of_lt (l : List α) (i : ℕ) (r : Option α) (h : i < l.length) : + (l.foldl stepFn (i + 1, r)).2 = some l[i] := by + induction l generalizing i r with + | nil => simp at h + | cons x xs ih => + rw [List.length_cons] at h + cases i with + | zero => + rw [List.foldl_cons] + change (xs.foldl stepFn (0 + 1 - 1, if 0 + 1 = 1 then some x else r)).2 = some (x :: xs)[0] + rw [ite_eq_left rfl] + simp [foldl_zero] + | succ k => + rw [List.foldl_cons] + change (xs.foldl stepFn (k + 1 + 1 - 1, if k + 1 + 1 = 1 then some x else r)).2 + = some (x :: xs)[k + 1] + rw [ite_eq_right (by omega), show k + 1 + 1 - 1 = k + 1 from by omega, + List.getElem_cons_succ] + exact ih k r (by omega) + +/-- **The fold computes list indexing.** -/ +lemma foldFun_snd (p : ℕ × List α) : + (foldFun listFn initFn stepFn p).2 = p.2[p.1]? := by + obtain ⟨i, l⟩ := p + change (l.foldl stepFn (i + 1, none)).2 = l[i]? + by_cases h : i < l.length + · rw [foldl_snd_of_lt l i none h, List.getElem?_eq_getElem h] + · rw [foldl_snd_of_ge l i none (by omega), List.getElem?_eq_none (by omega)] + +/-! ### Size bookkeeping -/ + +private lemma mem_of_mem_take {l : List α} {j : ℕ} {x : α} (h : x ∈ l.take j) : x ∈ l := by + induction l generalizing j with + | nil => simp at h + | cons y ys ih => + cases j with + | zero => simp at h + | succ k => + rw [List.take_succ_cons] at h + rcases List.mem_cons.mp h with h | h + · simp [h] + · exact List.mem_cons_of_mem _ (ih h) + +/-- The counter never exceeds its initial value. -/ +lemma foldl_fst_le (l : List α) (m : ℕ) (r : Option α) : + (l.foldl stepFn (m, r)).1 ≤ m := by + induction l generalizing m r with + | nil => simp + | cons x xs ih => + simp only [List.foldl_cons, stepFn] + exact le_trans (ih _ _) (Nat.sub_le _ _) + +/-- The "found so far" component is either the one we started with or an element of the list. -/ +lemma foldl_snd_mem (l : List α) (m : ℕ) (r : Option α) : + (l.foldl stepFn (m, r)).2 = r ∨ ∃ x ∈ l, (l.foldl stepFn (m, r)).2 = some x := by + induction l generalizing m r with + | nil => exact Or.inl rfl + | cons x xs ih => + simp only [List.foldl_cons, stepFn] + rcases ih (m - 1) (if m = 1 then some x else r) with h | ⟨y, hy, hy2⟩ + · rw [h] + by_cases hm : m = 1 + · exact Or.inr ⟨x, by simp, by simp [hm]⟩ + · exact Or.inl (by simp [hm]) + · exact Or.inr ⟨y, List.mem_cons_of_mem _ hy, hy2⟩ + +/-- The list folded over is a component of the input, so it is no bigger: `S n = n`. -/ +lemma listSize [DataEncode α] (p : ℕ × List α) : + (DataEncode.encode (listFn p)).size ≤ (DataEncode.encode p).size := by + obtain ⟨i, l⟩ := p + rw [DataEncode.size_pair] + change (DataEncode.encode l).size ≤ _ + omega + +/-- **The accumulator stays linear in the input: `A n = n + 8`.** + +The counter is at most `i + 1`, whose encoding costs at most six more than that of `i` (this is +where size-monotonicity of the `ℕ` encoding is used); the element found so far is either `none` or +a subtree of the encoded list. -/ +lemma accSize [DataEncode α] (p : ℕ × List α) (j : ℕ) : + (DataEncode.encode (foldAcc listFn initFn stepFn p j)).size + ≤ (DataEncode.encode p).size + 8 := by + obtain ⟨i, l⟩ := p + have hacc : foldAcc listFn initFn stepFn (i, l) j + = (l.take j).foldl stepFn (i + 1, none) := rfl + -- the counter component + have h1 : ((l.take j).foldl stepFn (i + 1, none)).1 ≤ i + 1 := foldl_fst_le _ _ _ + have h1' : (DataEncode.encode ((l.take j).foldl stepFn (i + 1, none)).1).size + ≤ (DataEncode.encode i).size + 6 := + le_trans (DataEncode.size_nat_mono h1) (DataEncode.size_nat_succ i) + -- the "found so far" component + have h2 : (DataEncode.encode ((l.take j).foldl stepFn (i + 1, none)).2).size + ≤ (DataEncode.encode l).size + 2 := by + rcases foldl_snd_mem (l.take j) (i + 1) none with h | ⟨x, hx, hx2⟩ + · rw [h, DataEncode.size_none] + omega + · rw [hx2, DataEncode.size_some] + have := DataEncode.size_mem_le (mem_of_mem_take hx) + omega + -- split the encoded pair (uses eta for structures) + have hsplit : (DataEncode.encode ((l.take j).foldl stepFn (i + 1, none))).size + = (DataEncode.encode ((l.take j).foldl stepFn (i + 1, none)).1).size + + (DataEncode.encode ((l.take j).foldl stepFn (i + 1, none)).2).size + 2 := + DataEncode.size_pair _ _ + rw [hacc, hsplit, DataEncode.size_pair] + omega + +/-- The output of the fold is an accumulator, so it obeys the same bound: `S_f n = n + 8`. -/ +lemma foldOutSize [DataEncode α] (p : ℕ × List α) : + (DataEncode.encode (foldFun listFn initFn stepFn p)).size + ≤ (DataEncode.encode p).size + 8 := by + rw [← foldAcc_length listFn initFn stepFn p] + exact accSize p _ + +/-! ### The complexity statement -/ + +/-- +**Indexing into a list runs in polynomial time and linear space.** + +Given that the three ingredients of the fold — taking the list component, building the initial +accumulator, and one countdown step — as well as the final projection are each computable in +polynomial time and linear space, so is `fun (i, l) => l[i]?`. + +Unfolded, the composed bounds are time `2n² + 13n + 8` and space `8n + 34` in the encoded input +size `n`, which `ComputableUpTo.absorb` restates as "polynomial, linear". The quadratic time is +not an artefact of the slack: the fold really does rescan the accumulator once per element. +-/ +theorem listIndex_polyTimeLinSpace [DataEncode α] + (h_list : PolyTimeLinSpace (listFn (α := α))) + (h_init : PolyTimeLinSpace (initFn (α := α))) + (h_step : PolyTimeLinSpace (Function.uncurry (stepFn (α := α)))) + (h_snd : PolyTimeLinSpace (Prod.snd : ℕ × Option α → Option α)) : + PolyTimeLinSpace (fun p : ℕ × List α => p.2[p.1]?) := by + -- The fold itself: `S n = n`, `A n = n + 8`, hence step arguments of size at most `2n + 10`. + have h_fold := foldl_computableUpTo listFn initFn stepFn + (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) + (fun n => n + 8) (fun n => n) + h_list h_init h_step monotone_id monotone_id listSize accSize + -- Project the answer out of the accumulator. + have h_comp := ComputableUpTo.comp (S_f := fun n => n + 8) h_fold h_snd + monotone_id monotone_id (foldOutSize (α := α)) + have h_eq : (Prod.snd ∘ foldFun listFn initFn stepFn) = fun p : ℕ × List α => p.2[p.1]? := + funext fun p => foldFun_snd p + rw [h_eq] at h_comp + -- Absorb the composed closed form into "polynomial time, linear space": + -- time `2n² + 13n + 8 ≤ 2 * (n + n + 2)²`, space `8n + 34 ≤ 34 * (n + 1)`. + refine h_comp.absorb 2 2 34 (fun n => ?_) (fun n => ?_) + · nlinarith [sq_nonneg n] + · omega + +end ListIndex + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean new file mode 100644 index 0000000000..d7247e5f45 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives + +/-! +# Example: `List.map` +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +/-! ## 1. `List.map` + +`List.map f l = l.foldl (fun acc x => acc ++ [f x]) []`, so the list is the input itself, the +initial accumulator is empty, and the accumulator at any point is a prefix of the result. + +The hypothesis that matters is `h_out`: each output element is at most a *constant factor* larger +than its input. That makes the accumulator linear in the input — the sum of the output sizes is +bounded by `c` times the sum of the input sizes, which is the encoded size of the input list. A +merely polynomial per-element bound would give a polynomial-space, not linear-space, result. +-/ + +namespace ListMap + +variable {α β : Type} + +/-- The step of `List.map` as a fold: append the image of the next element. -/ +def mapStep (f : α → β) (acc : List β) (x : α) : List β := acc ++ [f x] + +/-- The initial accumulator of the `List.map` fold. -/ +def mapInit (_ : List α) : List β := [] + +lemma foldl_mapStep (f : α → β) (l : List α) (acc : List β) : + l.foldl (mapStep f) acc = acc ++ l.map f := by + induction l generalizing acc with + | nil => simp + | cons x xs ih => simp [mapStep, ih] + +/-- **The fold computes `List.map`.** -/ +lemma foldFun_map (f : α → β) (l : List α) : + foldFun (id : List α → List α) mapInit (mapStep f) l = l.map f := by + simpa [foldFun, mapInit] using foldl_mapStep f l [] + +lemma foldAcc_map (f : α → β) (l : List α) (j : ℕ) : + foldAcc (id : List α → List α) mapInit (mapStep f) l j = (l.take j).map f := by + simpa [foldAcc, mapInit] using foldl_mapStep f (l.take j) [] + +variable [DataEncode α] [DataEncode β] + +omit [DataEncode β] in +lemma mapListSize (l : List α) : + (DataEncode.encode (id l)).size ≤ (DataEncode.encode l).size := le_refl _ + +/-- **The accumulator stays linear**: it is a prefix of the output, and each output element is at +most `c` times its input element, so the whole accumulator is at most `c` times the input list. -/ +lemma mapAccSize (f : α → β) (c : ℕ) + (h_out : ∀ x : α, (DataEncode.encode (f x)).size ≤ c * (DataEncode.encode x).size) + (l : List α) (j : ℕ) : + (DataEncode.encode (foldAcc (id : List α → List α) mapInit (mapStep f) l j)).size + ≤ 2 + c * (DataEncode.encode l).size := by + rw [foldAcc_map, DataEncode.size_list, List.map_map] + have h1 : ((l.take j).map ((fun y => (DataEncode.encode y).size) ∘ f)).sum + ≤ (l.map ((fun y => (DataEncode.encode y).size) ∘ f)).sum := sum_map_take_le _ _ _ + have h2 : (l.map ((fun y => (DataEncode.encode y).size) ∘ f)).sum + ≤ c * (l.map fun x => (DataEncode.encode x).size).sum := + sum_map_le_of_le l _ _ c fun x _ => h_out x + have h3 : c * (l.map fun x => (DataEncode.encode x).size).sum + ≤ c * (DataEncode.encode l).size := + Nat.mul_le_mul_left c (by rw [DataEncode.size_list]; omega) + omega + +/-- +**`List.map f` runs in polynomial time and linear space**, provided the fold's ingredients do and +each output element is at most a constant factor larger than its input. + +Unlike `ListIndex`, no final projection is needed: the accumulator *is* the result, so this +follows from `foldl_computableUpTo` alone. +-/ +theorem map_polyTimeLinSpace (f : α → β) (c : ℕ) + (h_list : PolyTimeLinSpace (id : List α → List α)) + (h_init : PolyTimeLinSpace (mapInit : List α → List β)) + (h_step : PolyTimeLinSpace (Function.uncurry (mapStep f))) + (h_out : ∀ x : α, (DataEncode.encode (f x)).size ≤ c * (DataEncode.encode x).size) : + PolyTimeLinSpace (fun l : List α => l.map f) := by + have h_fold := foldl_computableUpTo (id : List α → List α) mapInit (mapStep f) + (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) + (fun n => 2 + c * n) (fun n => n) + h_list h_init h_step monotone_id monotone_id mapListSize (mapAccSize f c h_out) + have h_eq : foldFun (id : List α → List α) mapInit (mapStep f) = fun l : List α => l.map f := + funext (foldFun_map f) + rw [h_eq] at h_fold + refine h_fold.absorb (c + 8) 2 (2 * c + 6) (fun n => ?_) (fun n => ?_) + · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring + rw [hexp] + nlinarith + · nlinarith + +/-- **`List.map` in the `Bounds` algebra.** + +The same result as `map_polyTimeLinSpace`, built compositionally instead of by discharging a list +of hypotheses. Compare the call sites: the monotonicity side conditions (`monotone_id monotone_id` +above) have vanished, because monotonicity travels inside the certificates, and the output-size +bound is a *field* of `Bounds.fold`'s result rather than an implicit argument that has to be +supplied by hand. + +The bounds it computes are, with `hstep` the step's certificate and `A n = 2 + c * n`: +`time n = (n + 2) + 4 + n * hstep.time (A n + n + 2)` and +`space n = hstep.space (A n + n + 2) + A n + n`. -/ +def mapBounds (f : α → β) (c : ℕ) + (hstep : Bounds (Function.uncurry (mapStep f))) + (h_out : ∀ x : α, (DataEncode.encode (f x)).size ≤ c * (DataEncode.encode x).size) : + Bounds (fun l : List α => l.map f) := + (Bounds.fold (Bounds.id : Bounds (id : List α → List α)) + (Bounds.const [] : Bounds (mapInit : List α → List β)) hstep + (fun n => 2 + c * n) + (by intro x y h; exact Nat.add_le_add_left (Nat.mul_le_mul_left c h) 2) + (mapAccSize f c h_out)).congr (funext (foldFun_map f)) + +end ListMap + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean new file mode 100644 index 0000000000..8cd48c8ada --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives + +/-! +# Example: association-list lookup + +Looking a key up in an association list is a fold: walk the entries carrying the key and whatever +has been found so far. As with list indexing, the key has to live in the accumulator, because a +fold's step never sees the original input. + +This is the piece a universal machine needs that a fixed transition function does not: its +transition table arrives on the input, so consulting it is a search rather than a case +distinction. + +The accumulator bound is unusually easy here. When keys and values are finite types the whole +accumulator type `K × Option V` is finite, so its encoded size is bounded by a *constant* — no +membership argument of the kind `ListIndex` needed. The lookup therefore costs linear space +regardless of how large the table is. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +namespace Lookup + +variable {K V : Type} [DataEncode K] [DataEncode V] [BEq K] + +/-- An association list. -/ +abbrev Table (K V : Type) := List (K × V) + +/-- The list the lookup folds over: the table itself. -/ +def lookupList (p : Table K V × K) : Table K V := p.1 + +/-- The initial accumulator: the key being searched for, and nothing found yet. -/ +def lookupInit (p : Table K V × K) : K × Option V := (p.2, none) + +/-- One step: keep whatever has already been found, otherwise take this entry if its key +matches. -/ +def lookupStep (acc : K × Option V) (kv : K × V) : K × Option V := + (acc.1, cond acc.2.isSome acc.2 (cond (kv.1 == acc.1) (some kv.2) none)) + +/-- The value of the first entry with the given key, or `none`. -/ +def firstMatch (k : K) : Table K V → Option V + | [] => none + | kv :: rest => cond (kv.1 == k) (some kv.2) (firstMatch k rest) + +/-! ### Correctness of the fold -/ + +omit [DataEncode K] [DataEncode V] in +/-- Once a value has been found the fold keeps it: later matches cannot overwrite it. -/ +lemma foldl_lookupStep_some (l : Table K V) (k : K) (v : V) : + (l.foldl lookupStep (k, some v)).2 = some v := by + induction l generalizing k v with + | nil => rfl + | cons kv l ih => simpa [lookupStep] using ih k v + +omit [DataEncode K] [DataEncode V] in +/-- **The fold is a lookup.** -/ +lemma foldl_lookupStep_none (l : Table K V) (k : K) : + (l.foldl lookupStep (k, none)).2 = firstMatch k l := by + induction l generalizing k with + | nil => rfl + | cons kv l ih => + rw [List.foldl_cons] + change (l.foldl lookupStep (k, cond (kv.1 == k) (some kv.2) none)).2 = _ + cases h : kv.1 == k with + | false => simpa [firstMatch, h] using ih k + | true => simpa [firstMatch, h] using foldl_lookupStep_some l k kv.2 + +/-- Lookup, as the second component of the fold's result. -/ +def lookupFn (p : Table K V × K) : Option V := + (foldFun lookupList lookupInit lookupStep p).2 + +omit [DataEncode K] [DataEncode V] in +@[simp] +lemma lookupFn_eq (tbl : Table K V) (k : K) : lookupFn (tbl, k) = firstMatch k tbl := + foldl_lookupStep_none tbl k + +/-! ### Size bookkeeping -/ + +/-- Every accumulator of the lookup fold inhabits the finite type `K × Option V`, so its encoded +size is bounded by a constant of the types alone. -/ +def accBound (K V : Type) [DataEncode K] [DataEncode V] [Fintype K] [Fintype V] : ℕ := + Finset.univ.sup fun a : K × Option V => (DataEncode.encode a).size + +lemma lookupAccSize [Fintype K] [Fintype V] (p : Table K V × K) (j : ℕ) : + (DataEncode.encode (foldAcc lookupList lookupInit lookupStep p j)).size ≤ accBound K V := + Finset.le_sup (f := fun a : K × Option V => (DataEncode.encode a).size) (Finset.mem_univ _) + +omit [BEq K] in +lemma lookupListSize (p : Table K V × K) : + (DataEncode.encode (lookupList p)).size ≤ (DataEncode.encode p).size := by + obtain ⟨tbl, k⟩ := p + have h : (DataEncode.encode ((tbl, k) : Table K V × K)).size + = (DataEncode.encode tbl).size + (DataEncode.encode k).size + 2 := + DataEncode.size_pair _ _ + change (DataEncode.encode tbl).size ≤ _ + omega + +/-! ### The certificate -/ + +/-- **A resource certificate for lookup**, from `Bounds.fold`. The step is a function between +finite types, and the accumulator bound is the constant `accBound`, so nothing beyond the +primitives is assumed. -/ +def lookupBounds [Fintype K] [Fintype V] : + Bounds (lookupFn : Table K V × K → Option V) := + let hl : Bounds (lookupList : Table K V × K → Table K V) := + (Bounds.fst : Bounds (Prod.fst : Table K V × K → Table K V)).congr rfl + let hi : Bounds (lookupInit : Table K V × K → K × Option V) := + (Bounds.pair (Bounds.snd : Bounds (Prod.snd : Table K V × K → K)) + (Bounds.const (none : Option V))).congr rfl + let hs : Bounds (Function.uncurry (lookupStep : K × Option V → K × V → K × Option V)) := + Bounds.ofFintype _ + Bounds.comp (Bounds.snd : Bounds (Prod.snd : K × Option V → Option V)) + (Bounds.fold hl hi hs (fun _ => accBound K V) monotone_const lookupAccSize) + +end Lookup + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean new file mode 100644 index 0000000000..eaef82faeb --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean @@ -0,0 +1,333 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold + +/-! +# Examples: `Nat.succ` and `Nat.add` + +Both are folds over `Nat.bits`, which is little-endian, so `List.foldl` visits the least +significant bit first — exactly the order carry propagation needs. Both produce a bit list and read +it back with `natOfBits`, which avoids having to prove that the output is canonical. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +/-- Flush a pending carry onto the emitted bits and read them back as a number. Shared by the +two arithmetic examples: both fold a carry along the bits and finish the same way. -/ +def flushCarry (acc : Bool × List Bool) : ℕ := + natOfBits (acc.2 ++ cond acc.1 [true] []) + +/-! ## 2. `Nat.succ` + +Incrementing a binary numeral is carry propagation, and `Nat.bits` is little-endian, so +`List.foldl` over it visits the bits in exactly the order the carry travels. + +The accumulator is the pending carry together with the output bits emitted so far. The step is the +half adder `(c, out) b ↦ (c && b, out ++ [c ^^ b])`; at the end `flushCarry` flushes a surviving +carry and reads the bits back as a number. +-/ + +namespace NatSucc + +/-- The list the increment folds over: the bits of the input, least significant first. -/ +def succList (n : ℕ) : List Bool := n.bits + +/-- The initial accumulator: carry one, nothing emitted yet. -/ +def succInit (_ : ℕ) : Bool × List Bool := (true, []) + +/-- Half adder: emit `c ^^ b` and carry `c && b`. -/ +def succStep (acc : Bool × List Bool) (b : Bool) : Bool × List Bool := + (acc.1 && b, acc.2 ++ [Bool.xor acc.1 b]) + +/-- Closed form of the increment: the outgoing carry together with the emitted bits. -/ +def incSpec (c : Bool) : List Bool → Bool × List Bool + | [] => (c, []) + | b :: bs => + let r := incSpec (c && b) bs + (r.1, Bool.xor c b :: r.2) + +lemma foldl_succStep (bs : List Bool) (c : Bool) (out : List Bool) : + bs.foldl succStep (c, out) = ((incSpec c bs).1, out ++ (incSpec c bs).2) := by + induction bs generalizing c out with + | nil => simp [incSpec] + | cons b bs ih => simp [succStep, incSpec, ih] + +lemma incSpec_length (c : Bool) (bs : List Bool) : (incSpec c bs).2.length = bs.length := by + induction bs generalizing c with + | nil => simp [incSpec] + | cons b bs ih => simp [incSpec, ih] + +/-- **The carry fold is correct**: flushing the carry yields the value plus the incoming carry. -/ +lemma natOfBits_incSpec (c : Bool) (bs : List Bool) : + natOfBits ((incSpec c bs).2 ++ cond (incSpec c bs).1 [true] []) + = natOfBits bs + cond c 1 0 := by + induction bs generalizing c with + | nil => cases c <;> simp [incSpec, Nat.bit_eq_two_mul_add] + | cons b bs ih => + have h := ih (c && b) + simp only [incSpec, List.cons_append, natOfBits_cons, Nat.bit_eq_two_mul_add] + rw [h] + cases c <;> cases b + all_goals simp + all_goals omega + +/-- **The fold computes `Nat.succ`.** -/ +lemma flushCarry_foldFun (n : ℕ) : + flushCarry (foldFun succList succInit succStep n) = n + 1 := by + have hf : foldFun succList succInit succStep n = n.bits.foldl succStep (true, []) := rfl + rw [hf, foldl_succStep] + simp only [flushCarry, List.nil_append] + rw [natOfBits_incSpec, natOfBits_bits] + simp + +/-! ### Size bookkeeping -/ + +lemma succListSize (n : ℕ) : + (DataEncode.encode (succList n)).size ≤ (DataEncode.encode n).size := by + have h1 := DataEncode.size_bits_le n.bits + have h2 : (DataEncode.encode n).size = 2 + 6 * n.size := DataEncode.size_nat n + have h3 : n.bits.length = n.size := Nat.size_eq_bits_len n + simp only [succList] + omega + +/-- **The accumulator stays linear**: it holds one carry bit and one emitted bit per bit consumed, +and the input has at most `(encode n).size` bits. -/ +lemma succAccSize (n j : ℕ) : + (DataEncode.encode (foldAcc succList succInit succStep n j)).size + ≤ 4 * (DataEncode.encode n).size + 8 := by + have hacc : foldAcc succList succInit succStep n j + = ((incSpec true (n.bits.take j)).1, [] ++ (incSpec true (n.bits.take j)).2) := by + simp only [foldAcc, succList, succInit] + exact foldl_succStep _ _ _ + rw [hacc, DataEncode.size_pair] + have hc : (DataEncode.encode (incSpec true (n.bits.take j)).1).size ≤ 4 := + DataEncode.size_bool _ + have hlen : ([] ++ (incSpec true (n.bits.take j)).2).length ≤ n.bits.length := by + simp only [List.nil_append, incSpec_length, List.length_take] + omega + have hout := DataEncode.size_bits_le ([] ++ (incSpec true (n.bits.take j)).2) + have h2 : (DataEncode.encode n).size = 2 + 6 * n.size := DataEncode.size_nat n + have h3 : n.bits.length = n.size := Nat.size_eq_bits_len n + omega + +lemma succFoldOutSize (n : ℕ) : + (DataEncode.encode (foldFun succList succInit succStep n)).size + ≤ 4 * (DataEncode.encode n).size + 8 := by + rw [← foldAcc_length succList succInit succStep n] + exact succAccSize n _ + +/-- **`Nat.succ` runs in polynomial time and linear space.** -/ +theorem succ_polyTimeLinSpace + (h_list : PolyTimeLinSpace succList) + (h_init : PolyTimeLinSpace succInit) + (h_step : PolyTimeLinSpace (Function.uncurry succStep)) + (h_finish : PolyTimeLinSpace flushCarry) : + PolyTimeLinSpace Nat.succ := by + have h_fold := foldl_computableUpTo succList succInit succStep + (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) + (fun n => 4 * n + 8) (fun n => n) + h_list h_init h_step monotone_id monotone_id succListSize succAccSize + have h_comp := ComputableUpTo.comp (S_f := fun n => 4 * n + 8) h_fold h_finish + monotone_id monotone_id succFoldOutSize + have h_eq : flushCarry ∘ foldFun succList succInit succStep = Nat.succ := + funext flushCarry_foldFun + rw [h_eq] at h_comp + refine h_comp.absorb 6 2 34 (fun n => ?_) (fun n => ?_) + · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring + rw [hexp] + nlinarith + · omega + +end NatSucc + +/-! ## 3. `Nat.add` + +A ripple-carry adder. The list folded over is the two bit lists zipped, each padded with zeros to +their common length, so one `foldl` step is one full adder. + +The correctness invariant is stated with `natOfBits` on both sides, which is what makes it a +routine induction: no reasoning about canonical forms is needed, only that the emitted bits carry +the right *value*. +-/ + +namespace NatAdd + +/-- The sum bit of a full adder. -/ +def sumBit (c x y : Bool) : Bool := Bool.xor (Bool.xor c x) y + +/-- The carry-out of a full adder. -/ +def carryOut (c x y : Bool) : Bool := (x && y) || (c && Bool.xor x y) + +/-- Pad a bit list with zeros to length at least `k`. -/ +def padTo (bs : List Bool) (k : ℕ) : List Bool := bs ++ List.replicate (k - bs.length) false + +@[simp] +lemma padTo_length (bs : List Bool) (k : ℕ) : (padTo bs k).length = max bs.length k := by + simp only [padTo, List.length_append, List.length_replicate] + omega + +@[simp] +lemma natOfBits_padTo (bs : List Bool) (k : ℕ) : natOfBits (padTo bs k) = natOfBits bs := by + simp [padTo] + +/-- The list the adder folds over: the two bit lists, zero-padded to a common length and zipped. -/ +def addList (p : ℕ × ℕ) : List (Bool × Bool) := + (padTo p.1.bits (max p.1.bits.length p.2.bits.length)).zip + (padTo p.2.bits (max p.1.bits.length p.2.bits.length)) + +/-- The initial accumulator: no carry in, nothing emitted yet. -/ +def addInit (_ : ℕ × ℕ) : Bool × List Bool := (false, []) + +/-- One full-adder step. -/ +def addStep (acc : Bool × List Bool) (xy : Bool × Bool) : Bool × List Bool := + (carryOut acc.1 xy.1 xy.2, acc.2 ++ [sumBit acc.1 xy.1 xy.2]) + +/-- Closed form of the adder: the outgoing carry together with the emitted bits. -/ +def addSpec (c : Bool) : List (Bool × Bool) → Bool × List Bool + | [] => (c, []) + | xy :: ps => + let r := addSpec (carryOut c xy.1 xy.2) ps + (r.1, sumBit c xy.1 xy.2 :: r.2) + +lemma foldl_addStep (ps : List (Bool × Bool)) (c : Bool) (out : List Bool) : + ps.foldl addStep (c, out) = ((addSpec c ps).1, out ++ (addSpec c ps).2) := by + induction ps generalizing c out with + | nil => simp [addSpec] + | cons xy ps ih => simp [addStep, addSpec, ih] + +lemma addSpec_length (c : Bool) (ps : List (Bool × Bool)) : + (addSpec c ps).2.length = ps.length := by + induction ps generalizing c with + | nil => simp [addSpec] + | cons xy ps ih => simp [addSpec, ih] + +/-- **The ripple-carry invariant.** -/ +lemma natOfBits_addSpec (c : Bool) (ps : List (Bool × Bool)) : + natOfBits ((addSpec c ps).2 ++ cond (addSpec c ps).1 [true] []) + = natOfBits (ps.map Prod.fst) + natOfBits (ps.map Prod.snd) + cond c 1 0 := by + induction ps generalizing c with + | nil => cases c <;> simp [addSpec, Nat.bit_eq_two_mul_add] + | cons xy ps ih => + obtain ⟨x, y⟩ := xy + have h := ih (carryOut c x y) + simp only [addSpec, List.cons_append, List.map_cons, natOfBits_cons, + Nat.bit_eq_two_mul_add] + rw [h] + cases c <;> cases x <;> cases y <;> simp [sumBit, carryOut] <;> omega + +/-! ### Reading the two summands back off the padded, zipped list -/ + +lemma map_fst_addList (p : ℕ × ℕ) : + (addList p).map Prod.fst = padTo p.1.bits (max p.1.bits.length p.2.bits.length) := + List.map_fst_zip (by simp) + +lemma map_snd_addList (p : ℕ × ℕ) : + (addList p).map Prod.snd = padTo p.2.bits (max p.1.bits.length p.2.bits.length) := + List.map_snd_zip (by simp) + +@[simp] +lemma addList_length (p : ℕ × ℕ) : + (addList p).length = max p.1.bits.length p.2.bits.length := by + simp only [addList, List.length_zip, padTo_length] + omega + +/-- **The fold computes `Nat.add`.** -/ +lemma flushCarry_foldFun (p : ℕ × ℕ) : + flushCarry (foldFun addList addInit addStep p) = p.1 + p.2 := by + have hf : foldFun addList addInit addStep p = (addList p).foldl addStep (false, []) := rfl + rw [hf, foldl_addStep] + simp only [flushCarry, List.nil_append] + rw [natOfBits_addSpec, map_fst_addList, map_snd_addList, natOfBits_padTo, natOfBits_padTo, + natOfBits_bits, natOfBits_bits] + simp + +/-! ### Size bookkeeping -/ + +lemma addListSize (p : ℕ × ℕ) : + (DataEncode.encode (addList p)).size ≤ 2 + 10 * (DataEncode.encode p).size := by + have hb : ∀ xy ∈ addList p, (DataEncode.encode xy).size ≤ 10 := by + intro xy _ + obtain ⟨x, y⟩ := xy + have := DataEncode.size_bool x + have := DataEncode.size_bool y + rw [DataEncode.size_pair] + omega + have h1 := DataEncode.size_list_le (addList p) 10 hb + have h2 : (addList p).length ≤ (DataEncode.encode p).size := by + obtain ⟨a, b⟩ := p + have ha := DataEncode.bits_length_le a + have hb' := DataEncode.bits_length_le b + rw [DataEncode.size_pair] + simp only [addList_length] + omega + omega + +/-- **The accumulator stays linear**: one carry bit plus one emitted bit per position. -/ +lemma addAccSize (p : ℕ × ℕ) (j : ℕ) : + (DataEncode.encode (foldAcc addList addInit addStep p j)).size + ≤ 4 * (DataEncode.encode p).size + 8 := by + have hacc : foldAcc addList addInit addStep p j + = ((addSpec false ((addList p).take j)).1, + [] ++ (addSpec false ((addList p).take j)).2) := by + simp only [foldAcc, addInit] + exact foldl_addStep _ _ _ + rw [hacc, DataEncode.size_pair] + have hc : (DataEncode.encode (addSpec false ((addList p).take j)).1).size ≤ 4 := + DataEncode.size_bool _ + have hout := DataEncode.size_bits_le ([] ++ (addSpec false ((addList p).take j)).2) + have hlen : ([] ++ (addSpec false ((addList p).take j)).2).length + ≤ (DataEncode.encode p).size := by + simp only [List.nil_append, addSpec_length, List.length_take] + obtain ⟨a, b⟩ := p + have ha := DataEncode.bits_length_le a + have hb' := DataEncode.bits_length_le b + rw [DataEncode.size_pair] + simp only [addList_length] + omega + omega + +lemma addFoldOutSize (p : ℕ × ℕ) : + (DataEncode.encode (foldFun addList addInit addStep p)).size + ≤ 4 * (DataEncode.encode p).size + 8 := by + rw [← foldAcc_length addList addInit addStep p] + exact addAccSize p _ + +/-- **`Nat.add` runs in polynomial time and linear space.** -/ +theorem add_polyTimeLinSpace + (h_list : PolyTimeLinSpace addList) + (h_init : PolyTimeLinSpace addInit) + (h_step : PolyTimeLinSpace (Function.uncurry addStep)) + (h_finish : PolyTimeLinSpace flushCarry) : + PolyTimeLinSpace (fun p : ℕ × ℕ => p.1 + p.2) := by + have h_fold := foldl_computableUpTo addList addInit addStep + (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) + (fun n => 4 * n + 8) (fun n => 2 + 10 * n) + h_list h_init h_step monotone_id monotone_id addListSize addAccSize + have h_comp := ComputableUpTo.comp (S_f := fun n => 4 * n + 8) h_fold h_finish + monotone_id monotone_id addFoldOutSize + have h_eq : flushCarry ∘ foldFun addList addInit addStep = fun p : ℕ × ℕ => p.1 + p.2 := + funext flushCarry_foldFun + rw [h_eq] at h_comp + refine h_comp.absorb 40 2 38 (fun n => ?_) (fun n => ?_) + · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring + rw [hexp] + nlinarith + · omega + +end NatAdd + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean new file mode 100644 index 0000000000..cf32defc2b --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold + +/-! +# Example: `Nat.mul` + +Shift-and-add. Fold over the bits of the second factor carrying a pair: the partial product and +the current shift `a * 2 ^ j`. Each step adds the shift when the bit is set and then doubles it. + +Unlike `Nat.add`, this fold does not need the two arguments interleaved: it folds over one +factor's bits and keeps the other in the accumulator, so no padding or zipping is involved. The +step is where addition happens, so this example is genuinely *built on* the previous one rather +than circular — a step assumed here is a full addition, not a multiplication. + +The accumulator bound is the interesting part: after `j` steps the partial product is +`natOfBits (b.bits.take j) * a < 2 ^ j * a` and the shift is `a * 2 ^ j`, so both have bit length +at most `a.size + b.size + 1`. Since the encoded input size is `6 * (a.size + b.size) + 6`, the +accumulator stays *linear*, and the fold runs in polynomial time and linear space. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +namespace NatMul + +/-- The list the multiplier folds over: the bits of the second factor, least significant first. -/ +def mulList (p : ℕ × ℕ) : List Bool := p.2.bits + +/-- The initial accumulator: nothing accumulated yet, and the first factor as the initial shift. -/ +def mulInit (p : ℕ × ℕ) : ℕ × ℕ := (0, p.1) + +/-- Shift-and-add: add the current shift if the bit is set, then double the shift. -/ +def mulStep (acc : ℕ × ℕ) (b : Bool) : ℕ × ℕ := + (acc.1 + cond b acc.2 0, acc.2 + acc.2) + +/-! ### Correctness of the fold -/ + +/-- Closed form of the shift-and-add fold. -/ +lemma foldl_mulStep (bs : List Bool) (acc sh : ℕ) : + bs.foldl mulStep (acc, sh) = (acc + natOfBits bs * sh, sh * 2 ^ bs.length) := by + induction bs generalizing acc sh with + | nil => simp + | cons b bs ih => + rw [List.foldl_cons] + change (bs.foldl mulStep (acc + cond b sh 0, sh + sh)) = _ + rw [ih] + cases b <;> + simp only [natOfBits_cons, Nat.bit_eq_two_mul_add, List.length_cons, pow_succ, + Bool.cond_true, Bool.cond_false, Prod.mk.injEq] <;> + constructor <;> ring + +/-- **The fold computes `Nat.mul`.** -/ +lemma foldFun_mul (p : ℕ × ℕ) : + (foldFun mulList mulInit mulStep p).1 = p.1 * p.2 := by + obtain ⟨a, b⟩ := p + change (b.bits.foldl mulStep (0, a)).1 = a * b + rw [foldl_mulStep] + simp [natOfBits_bits, Nat.mul_comm] + +/-! ### Size bookkeeping -/ + +/-- The accumulator after `j` steps, in closed form. -/ +lemma foldAcc_mul (a b : ℕ) (j : ℕ) : + foldAcc mulList mulInit mulStep (a, b) j + = (natOfBits (b.bits.take j) * a, a * 2 ^ (b.bits.take j).length) := by + change ((b.bits.take j).foldl mulStep (0, a)) = _ + rw [foldl_mulStep] + simp + +/-- The prefix of a number's bits denotes something of no greater bit length. -/ +lemma size_natOfBits_take (b : ℕ) (j : ℕ) : + (natOfBits (b.bits.take j)).size ≤ b.size := by + have hlen : (b.bits.take j).length ≤ b.size := by + rw [List.length_take, Nat.size_eq_bits_len] + omega + exact Nat.size_le.mpr + (lt_of_lt_of_le (natOfBits_lt _) (Nat.pow_le_pow_right (by omega) hlen)) + +/-- **The accumulator stays linear.** Both components have bit length at most +`a.size + b.size + 1`, which the encoding turns into at most twice the input size. -/ +lemma mulAccSize (p : ℕ × ℕ) (j : ℕ) : + (DataEncode.encode (foldAcc mulList mulInit mulStep p j)).size + ≤ 2 * (DataEncode.encode p).size := by + obtain ⟨a, b⟩ := p + have hlen : (b.bits.take j).length ≤ b.size := by + rw [List.length_take, Nat.size_eq_bits_len] + omega + have h1 : (natOfBits (b.bits.take j) * a).size ≤ b.size + a.size := + le_trans (Nat.size_mul_le _ _) (Nat.add_le_add_right (size_natOfBits_take b j) _) + have h2 : (a * 2 ^ (b.bits.take j).length).size ≤ a.size + b.size + 1 := by + have := Nat.size_mul_le a (2 ^ (b.bits.take j).length) + have := Nat.size_two_pow_le (b.bits.take j).length + omega + rw [foldAcc_mul, DataEncode.size_pair, DataEncode.size_pair, + DataEncode.size_nat, DataEncode.size_nat, DataEncode.size_nat, DataEncode.size_nat] + omega + +/-- The list folded over is no bigger than the input. -/ +lemma mulListSize (p : ℕ × ℕ) : + (DataEncode.encode (mulList p)).size ≤ (DataEncode.encode p).size := by + obtain ⟨a, b⟩ := p + have h1 := DataEncode.size_bits_le b.bits + have h2 : b.bits.length = b.size := Nat.size_eq_bits_len b + change (DataEncode.encode b.bits).size ≤ _ + rw [DataEncode.size_pair, DataEncode.size_nat, DataEncode.size_nat] + omega + +lemma mulFoldOutSize (p : ℕ × ℕ) : + (DataEncode.encode (foldFun mulList mulInit mulStep p)).size + ≤ 2 * (DataEncode.encode p).size := by + rw [← foldAcc_length mulList mulInit mulStep p] + exact mulAccSize p _ + +/-- **`Nat.mul` runs in polynomial time and linear space.** -/ +theorem mul_polyTimeLinSpace + (h_list : PolyTimeLinSpace mulList) + (h_init : PolyTimeLinSpace mulInit) + (h_step : PolyTimeLinSpace (Function.uncurry mulStep)) + (h_fst : PolyTimeLinSpace (Prod.fst : ℕ × ℕ → ℕ)) : + PolyTimeLinSpace (fun p : ℕ × ℕ => p.1 * p.2) := by + have h_fold := foldl_computableUpTo mulList mulInit mulStep + (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) + (fun n => 2 * n) (fun n => n) + h_list h_init h_step monotone_id monotone_id mulListSize mulAccSize + have h_comp := ComputableUpTo.comp (S_f := fun n => 2 * n) h_fold h_fst + monotone_id monotone_id mulFoldOutSize + have h_eq : Prod.fst ∘ foldFun mulList mulInit mulStep = fun p : ℕ × ℕ => p.1 * p.2 := + funext foldFun_mul + rw [h_eq] at h_comp + refine h_comp.absorb 1 2 12 (fun n => ?_) (fun n => ?_) + · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring + rw [hexp] + nlinarith + · omega + +end NatMul + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean new file mode 100644 index 0000000000..84f86ef68a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives + +/-! +# Towards a universal machine: tapes and one simulated step + +A first step towards costing a universal machine: represent the tape of the *simulated* machine, +and give resource certificates for the tape operations and for one step of the simulation. + +## The tape + +A tape is a zipper: `Tape S = List S × List S`, the cells strictly left of the head in reverse +order, and the cells from the head rightwards. Cells beyond either end are the blank symbol, so +only finitely many cells are ever represented and a tape is an ordinary finite value. It therefore +**inherits `DataEncode` from the `List` and `Prod` instances with no new instance and no new +assumption** — which is the point of choosing a zipper over, say, a function `ℤ → S`. + +## What is proved here + +Everything in this file is *derived*: `read`, `write`, `moveL`, `moveR` and finally `simStep` all +get their certificates by composing `Bounds.fst`, `Bounds.snd`, `Bounds.cons`, `Bounds.pair`, +`Bounds.comp`, `Bounds.headD`, `Bounds.tail`, `Bounds.ite` and `Bounds.ofFintype`. **No new `sorry` +is introduced.** One step of a simulated single-tape machine costs no more than the primitives it +is built from, and the bound is computed rather than asserted. + +## What is still missing for a universal machine + +`simStep` takes its transition function `tr` as a *fixed* function on finite types, so +`Bounds.ofFintype` applies. A genuinely universal machine reads the transition table off its input +instead, which means looking a key up in an encoded association list — that is a fold with an +`Option` accumulator, structurally the same argument as `ListIndex`. That, plus iterating `simStep` +under a step counter, is what remains. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +namespace Simulation + +variable {S Q : Type} [DataEncode S] [DataEncode Q] + +/-- The tape of a simulated machine, as a zipper: the cells strictly left of the head in reverse +order, and the cells from the head rightwards. Everything beyond either end is blank, so only +finitely many cells are represented. -/ +abbrev Tape (S : Type) := List S × List S + +/-- The symbol under the head. -/ +def read (blank : S) (t : Tape S) : S := t.2.head?.getD blank + +/-- Overwrite the symbol under the head. -/ +def write (p : Tape S × S) : Tape S := (p.1.1, p.2 :: p.1.2.tail) + +/-- Move the head one cell to the right. -/ +def moveR (blank : S) (t : Tape S) : Tape S := (t.2.head?.getD blank :: t.1, t.2.tail) + +/-- Move the head one cell to the left. -/ +def moveL (blank : S) (t : Tape S) : Tape S := (t.1.tail, t.1.head?.getD blank :: t.2) + +/-! ### Certificates for the tape operations, derived from the primitives -/ + +/-- Reading is the head of the right-hand list. -/ +def readBounds (blank : S) : Bounds (read (S := S) blank) := + (Bounds.comp (Bounds.headD blank) Bounds.snd).congr rfl + +/-- Writing replaces the head of the right-hand list. -/ +def writeBounds : Bounds (write : Tape S × S → Tape S) := + (Bounds.pair (Bounds.comp Bounds.fst Bounds.fst) + (Bounds.cons Bounds.snd (Bounds.comp Bounds.tail (Bounds.comp Bounds.snd Bounds.fst)))).congr + rfl + +/-- Moving right pops the right-hand list and pushes onto the left-hand one. -/ +def moveRBounds (blank : S) : Bounds (moveR (S := S) blank) := + (Bounds.pair (Bounds.cons (Bounds.comp (Bounds.headD blank) Bounds.snd) Bounds.fst) + (Bounds.comp Bounds.tail Bounds.snd)).congr rfl + +/-- Moving left pops the left-hand list and pushes onto the right-hand one. -/ +def moveLBounds (blank : S) : Bounds (moveL (S := S) blank) := + (Bounds.pair (Bounds.comp Bounds.tail Bounds.fst) + (Bounds.cons (Bounds.comp (Bounds.headD blank) Bounds.fst) Bounds.snd)).congr rfl + +/-! ### How much the tape can grow + +One step changes the tape by a bounded amount. These are the lemmas the universal machine's space +bound is built from: writing costs at most the written symbol, and a move costs at most one blank +(only when the head runs off the represented part of the tape). -/ + +lemma size_write_le (p : Tape S × S) : + (DataEncode.encode (write p)).size + ≤ (DataEncode.encode p.1).size + (DataEncode.encode p.2).size := by + obtain ⟨⟨l, r⟩, s⟩ := p + have h1 : (DataEncode.encode (write ((l, r), s))).size + = (DataEncode.encode l).size + ((DataEncode.encode s).size + + (DataEncode.encode r.tail).size) + 2 := by + rw [show write ((l, r), s) = (l, s :: r.tail) from rfl, DataEncode.size_pair, + DataEncode.size_cons] + have h2 : (DataEncode.encode ((l, r) : Tape S)).size + = (DataEncode.encode l).size + (DataEncode.encode r).size + 2 := DataEncode.size_pair _ _ + have h3 := DataEncode.size_tail_le r + simp only [] + omega + +lemma size_moveR_le (blank : S) (t : Tape S) : + (DataEncode.encode (moveR blank t)).size + ≤ (DataEncode.encode t).size + (DataEncode.encode blank).size := by + obtain ⟨l, r⟩ := t + have h2 : (DataEncode.encode ((l, r) : Tape S)).size + = (DataEncode.encode l).size + (DataEncode.encode r).size + 2 := DataEncode.size_pair _ _ + cases r with + | nil => + have h1 : (DataEncode.encode (moveR blank ((l, []) : Tape S))).size + = ((DataEncode.encode blank).size + (DataEncode.encode l).size) + + (DataEncode.encode ([] : List S)).size + 2 := by + rw [show moveR blank ((l, []) : Tape S) = (blank :: l, []) from rfl, + DataEncode.size_pair, DataEncode.size_cons] + omega + | cons x xs => + have h1 : (DataEncode.encode (moveR blank ((l, x :: xs) : Tape S))).size + = ((DataEncode.encode x).size + (DataEncode.encode l).size) + + (DataEncode.encode xs).size + 2 := by + rw [show moveR blank ((l, x :: xs) : Tape S) = (x :: l, xs) from rfl, + DataEncode.size_pair, DataEncode.size_cons] + have h4 := DataEncode.size_cons x xs + omega + +lemma size_moveL_le (blank : S) (t : Tape S) : + (DataEncode.encode (moveL blank t)).size + ≤ (DataEncode.encode t).size + (DataEncode.encode blank).size := by + obtain ⟨l, r⟩ := t + have h2 : (DataEncode.encode ((l, r) : Tape S)).size + = (DataEncode.encode l).size + (DataEncode.encode r).size + 2 := DataEncode.size_pair _ _ + cases l with + | nil => + have h1 : (DataEncode.encode (moveL blank (([], r) : Tape S))).size + = (DataEncode.encode ([] : List S)).size + + ((DataEncode.encode blank).size + (DataEncode.encode r).size) + 2 := by + rw [show moveL blank (([], r) : Tape S) = ([], blank :: r) from rfl, + DataEncode.size_pair, DataEncode.size_cons] + omega + | cons x xs => + have h1 : (DataEncode.encode (moveL blank ((x :: xs, r) : Tape S))).size + = (DataEncode.encode xs).size + + ((DataEncode.encode x).size + (DataEncode.encode r).size) + 2 := by + rw [show moveL blank ((x :: xs, r) : Tape S) = (xs, x :: r) from rfl, + DataEncode.size_pair, DataEncode.size_cons] + have h4 := DataEncode.size_cons x xs + omega + +/-! ### Carrying out an instruction -/ + +/-- The instruction a transition produces: the new state, the symbol to write, and the direction +to move (`true` for right). -/ +abbrev Instr (Q S : Type) := Q × S × Bool + +/-- Carry out an instruction on a configuration: adopt the new state, write the symbol under the +head, and move. Factored out of `simStep` so that the universal machine, whose instruction comes +from a table lookup rather than a fixed function, can reuse it. -/ +def applyInstr (blank : S) (p : Instr Q S × (Q × Tape S)) : Q × Tape S := + (p.1.1, + cond p.1.2.2 + (moveR blank (write (p.2.2, p.1.2.1))) + (moveL blank (write (p.2.2, p.1.2.1)))) + +/-- A certificate for `applyInstr`, composed from the tape operations and `Bounds.ite`. -/ +def applyInstrBounds (blank : S) : Bounds (applyInstr (Q := Q) blank) := + let i : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1) := Bounds.fst + let st : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1.1) := + (Bounds.comp (Bounds.fst : Bounds (Prod.fst : Instr Q S → Q)) i).congr rfl + let sym : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1.2.1) := + (Bounds.comp (Bounds.comp (Bounds.fst : Bounds (Prod.fst : S × Bool → S)) + (Bounds.snd : Bounds (Prod.snd : Instr Q S → S × Bool))) i).congr rfl + let dir : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1.2.2) := + (Bounds.comp (Bounds.comp (Bounds.snd : Bounds (Prod.snd : S × Bool → Bool)) + (Bounds.snd : Bounds (Prod.snd : Instr Q S → S × Bool))) i).congr rfl + let tp : Bounds (fun p : Instr Q S × (Q × Tape S) => p.2.2) := + (Bounds.comp (Bounds.snd : Bounds (Prod.snd : Q × Tape S → Tape S)) + (Bounds.snd : Bounds (Prod.snd : Instr Q S × (Q × Tape S) → Q × Tape S))).congr rfl + let written : Bounds (fun p : Instr Q S × (Q × Tape S) => write (p.2.2, p.1.2.1)) := + (Bounds.comp writeBounds (Bounds.pair tp sym)).congr rfl + (Bounds.pair st + (Bounds.ite dir + (Bounds.comp (moveRBounds blank) written) + (Bounds.comp (moveLBounds blank) written))).congr rfl + +/-! ### One step of a simulated machine with a fixed transition function -/ + +/-- One step of a simulated single-tape machine with transition function `tr`. -/ +def simStep (blank : S) (tr : Q × S → Instr Q S) (c : Q × Tape S) : Q × Tape S := + applyInstr blank (tr (c.1, read blank c.2), c) + +/-- **A resource certificate for one simulated step**, composed entirely from the primitives: +`ofFintype` for the transition, the tape operations for the rest. Nothing new is assumed. -/ +def simStepBounds [Fintype Q] [Fintype S] (blank : S) (tr : Q × S → Instr Q S) : + Bounds (simStep blank tr) := + let rd : Bounds (fun c : Q × Tape S => read blank c.2) := + (Bounds.comp (readBounds blank) + (Bounds.snd : Bounds (Prod.snd : Q × Tape S → Tape S))).congr rfl + let instr : Bounds (fun c : Q × Tape S => tr (c.1, read blank c.2)) := + (Bounds.comp (Bounds.ofFintype tr) + (Bounds.pair (Bounds.fst : Bounds (Prod.fst : Q × Tape S → Q)) rd)).congr rfl + (Bounds.comp (applyInstrBounds blank) + (Bounds.pair instr (Bounds.id : Bounds (id : Q × Tape S → Q × Tape S)))).congr rfl + +end Simulation + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean new file mode 100644 index 0000000000..cbd9fb53d5 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean @@ -0,0 +1,365 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Lookup +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Tape +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.While + +/-! +# A universal machine + +The pieces assembled. A configuration of the universal machine is the transition table it is +interpreting together with the simulated machine's state and tape. One step looks the current +(state, symbol) pair up in that table — a fold, `Lookup.lookupFn` — and carries out the resulting +instruction — `Simulation.applyInstr`. Running the machine is `Bounds.while` over that step, with +the simulated machine's halting states as the test. + +Unlike `Simulation.simStep`, the transition function is *not* fixed: it arrives on the input, so +`Bounds.ofFintype` does not apply to it and the table has to be searched. That search is the only +genuinely new ingredient, and it is a fold. + +## The space bound + +`uRunBounds` computes `outSize n = n + N n * stepGrowth blank`: linear in the input plus the +number of simulated steps. This is the textbook bound, and it comes out of `Bounds.while`'s +asymmetry — the time bound carries the factor `N`, the space bound does not, because iterations +reuse tapes. The content behind it is `uStep_size_le`: one step grows the configuration by at +most a constant (a new state, a written symbol, and at most one fresh blank cell). + +`N` is supplied by the caller, as it must be: bounding the number of steps of the simulated +machine is exactly what a caller doing complexity theory knows and this file cannot. + +## No new assumptions + +Every certificate here is composed from the primitives and the two loop combinators. The file +introduces no `sorry` of its own. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine Simulation Lookup + +namespace Universal + +variable {Q S : Type} [DataEncode Q] [DataEncode S] [BEq (Q × S)] + +/-- The transition table a universal machine interprets. -/ +abbrev UTable (Q S : Type) := Lookup.Table (Q × S) (Instr Q S) + +/-- A configuration of the universal machine: the table it is interpreting, together with the +simulated machine's state and tape. -/ +abbrev UCfg (Q S : Type) := UTable Q S × Q × Tape S + +/-- One step of the universal machine: look the current (state, symbol) pair up in the table being +carried, then carry out the instruction found, or `dflt` if the pair is absent. -/ +def uStep (blank : S) (dflt : Instr Q S) (c : UCfg Q S) : UCfg Q S := + (c.1, applyInstr blank ((lookupFn (c.1, (c.2.1, read blank c.2.2))).getD dflt, c.2)) + +/-- The universal machine stops when the simulated state is a halting one. -/ +def uHalt (halting : Q → Bool) (c : UCfg Q S) : Bool := halting c.2.1 + +/-- A certificate for the halting test. -/ +def uHaltBounds [Fintype Q] (halting : Q → Bool) : Bounds (uHalt (S := S) halting) := + (Bounds.comp (Bounds.ofFintype halting) + (Bounds.comp (Bounds.fst : Bounds (Prod.fst : Q × Tape S → Q)) + (Bounds.snd : Bounds (Prod.snd : UCfg Q S → Q × Tape S)))).congr rfl + +/-- **A certificate for one universal step**, composed from the table lookup and the tape +operations. -/ +def uStepBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) : + Bounds (uStep blank dflt) := + let tbl : Bounds (fun c : UCfg Q S => c.1) := + (Bounds.fst : Bounds (Prod.fst : UCfg Q S → UTable Q S)) + let cfg : Bounds (fun c : UCfg Q S => c.2) := + (Bounds.snd : Bounds (Prod.snd : UCfg Q S → Q × Tape S)) + let st : Bounds (fun c : UCfg Q S => c.2.1) := + (Bounds.comp (Bounds.fst : Bounds (Prod.fst : Q × Tape S → Q)) cfg).congr rfl + let tp : Bounds (fun c : UCfg Q S => c.2.2) := + (Bounds.comp (Bounds.snd : Bounds (Prod.snd : Q × Tape S → Tape S)) cfg).congr rfl + let rd : Bounds (fun c : UCfg Q S => read blank c.2.2) := + (Bounds.comp (readBounds blank) tp).congr rfl + let look : Bounds (fun c : UCfg Q S => lookupFn (c.1, (c.2.1, read blank c.2.2))) := + (Bounds.comp lookupBounds (Bounds.pair tbl (Bounds.pair st rd))).congr rfl + let instr : Bounds (fun c : UCfg Q S => + (lookupFn (c.1, (c.2.1, read blank c.2.2))).getD dflt) := + (Bounds.comp (Bounds.optionGetD dflt) look).congr rfl + (Bounds.pair tbl (Bounds.comp (applyInstrBounds blank) (Bounds.pair instr cfg))).congr rfl + +/-! ### How fast a configuration can grow -/ + +/-- How much one universal step can grow the encoded configuration: a new state, a written symbol, +and at most one fresh blank cell. All three are bounded by constants of the types. -/ +def stepGrowth [Fintype Q] [Fintype S] (blank : S) : ℕ := + (Finset.univ.sup fun q : Q => (DataEncode.encode q).size) + + (Finset.univ.sup fun s : S => (DataEncode.encode s).size) + + (DataEncode.encode blank).size + +/-- **One step grows the configuration by at most a constant.** The table is carried unchanged, +the state is replaced by another element of a finite type, and the tape gains at most the written +symbol and one blank cell. -/ +lemma uStep_size_le [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) (c : UCfg Q S) : + (DataEncode.encode (uStep blank dflt c)).size + ≤ (DataEncode.encode c).size + stepGrowth (Q := Q) blank := by + obtain ⟨tbl, qt⟩ := c + set i : Instr Q S := (lookupFn (tbl, (qt.1, read blank qt.2))).getD dflt with hi + have hstep : (DataEncode.encode (uStep blank dflt (tbl, qt))).size + = (DataEncode.encode tbl).size + + (DataEncode.encode (applyInstr blank (i, qt))).size + 2 := + DataEncode.size_pair _ _ + have hc : (DataEncode.encode ((tbl, qt) : UCfg Q S)).size + = (DataEncode.encode tbl).size + (DataEncode.encode qt).size + 2 := + DataEncode.size_pair _ _ + have hqt : (DataEncode.encode qt).size + = (DataEncode.encode qt.1).size + (DataEncode.encode qt.2).size + 2 := + DataEncode.size_pair _ _ + -- the applied instruction + have happ : (DataEncode.encode (applyInstr blank (i, qt))).size + = (DataEncode.encode i.1).size + + (DataEncode.encode (cond i.2.2 + (moveR blank (write (qt.2, i.2.1))) (moveL blank (write (qt.2, i.2.1))))).size + 2 := + DataEncode.size_pair _ _ + have hwrite : (DataEncode.encode (write (qt.2, i.2.1))).size + ≤ (DataEncode.encode qt.2).size + (DataEncode.encode i.2.1).size := + size_write_le (qt.2, i.2.1) + have hmove : (DataEncode.encode (cond i.2.2 + (moveR blank (write (qt.2, i.2.1))) (moveL blank (write (qt.2, i.2.1))))).size + ≤ (DataEncode.encode (write (qt.2, i.2.1))).size + (DataEncode.encode blank).size := by + cases i.2.2 + · simpa using size_moveL_le blank (write (qt.2, i.2.1)) + · simpa using size_moveR_le blank (write (qt.2, i.2.1)) + -- the finite parts + have hq : (DataEncode.encode i.1).size + ≤ Finset.univ.sup fun q : Q => (DataEncode.encode q).size := + Finset.le_sup (f := fun q : Q => (DataEncode.encode q).size) (Finset.mem_univ _) + have hs : (DataEncode.encode i.2.1).size + ≤ Finset.univ.sup fun s : S => (DataEncode.encode s).size := + Finset.le_sup (f := fun s : S => (DataEncode.encode s).size) (Finset.mem_univ _) + unfold stepGrowth + omega + +/-! ### Running to completion -/ + +/-- **The universal machine run to completion.** + +Given `N` bounding the number of steps the simulated machine takes, this computes a certificate +for the whole run. Its `outSize` is `n + N n * stepGrowth blank` — linear in the input plus the +number of simulated steps. -/ +def uRunBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) (halting : Q → Bool) + (out : UCfg Q S → UCfg Q S) (steps : UCfg Q S → ℕ) + (h_out : ∀ c, out c = (uStep blank dflt)^[steps c] c) + (h_halt : ∀ c, uHalt halting ((uStep blank dflt)^[steps c] c) = true) + (h_first : ∀ c j, j < steps c → uHalt halting ((uStep blank dflt)^[j] c) = false) + (N : ℕ → ℕ) (hN_mono : Monotone N) + (hN : ∀ c, steps c ≤ N (DataEncode.encode c).size) : + Bounds out := + Bounds.while (Bounds.id : Bounds (id : UCfg Q S → UCfg Q S)) + (uHaltBounds halting) (uStepBounds blank dflt) steps + h_out h_halt h_first + N (fun n => n + N n * stepGrowth (Q := Q) blank) hN_mono + (fun _ _ h => Nat.add_le_add h (Nat.mul_le_mul (hN_mono h) (le_refl _))) + hN + (fun c j hj => by + have h1 := size_iterate_le (f := uStep blank dflt) (stepGrowth (Q := Q) blank) + (uStep_size_le blank dflt) j c + have h2 : j * stepGrowth (Q := Q) blank + ≤ N (DataEncode.encode c).size * stepGrowth (Q := Q) blank := + Nat.mul_le_mul_right _ (le_trans hj (hN c)) + simpa using by omega) + +/-! ## Variant 1: running under a step budget + +Instead of a bound `N` supplied by the caller, the budget arrives *on the input* as a unary list: +the machine takes one step per cell and stops early once the simulated machine halts. This is a +`Bounds.fold` rather than a `Bounds.while` — the trip count is a list — and it needs no +termination hypothesis at all, because the budget makes the run total. -/ + +/-- One step under a budget: do nothing once the simulated machine has halted. -/ +def budgetStep (blank : S) (dflt : Instr Q S) (halting : Q → Bool) (c : UCfg Q S) : UCfg Q S := + cond (uHalt halting c) c (uStep blank dflt c) + +/-- The list folded over: the step budget, in unary. -/ +def budgetList (p : List Unit × UCfg Q S) : List Unit := p.1 + +/-- The initial accumulator: the configuration to run. -/ +def budgetInit (p : List Unit × UCfg Q S) : UCfg Q S := p.2 + +/-- The fold's step ignores the budget cell; it only supplies a trip count. -/ +def budgetFoldStep (blank : S) (dflt : Instr Q S) (halting : Q → Bool) + (c : UCfg Q S) (_ : Unit) : UCfg Q S := + budgetStep blank dflt halting c + +omit [DataEncode Q] [DataEncode S] in +/-- **Running under a budget is iterating the budgeted step.** -/ +lemma foldFun_budget (blank : S) (dflt : Instr Q S) (halting : Q → Bool) + (fuel : List Unit) (c : UCfg Q S) : + foldFun budgetList budgetInit (budgetFoldStep blank dflt halting) (fuel, c) + = (budgetStep blank dflt halting)^[fuel.length] c := + foldl_const_iterate _ _ _ + +omit [DataEncode Q] [DataEncode S] in +lemma foldAcc_budget (blank : S) (dflt : Instr Q S) (halting : Q → Bool) + (fuel : List Unit) (c : UCfg Q S) (j : ℕ) : + foldAcc budgetList budgetInit (budgetFoldStep blank dflt halting) (fuel, c) j + = (budgetStep blank dflt halting)^[(fuel.take j).length] c := + foldl_const_iterate _ _ _ + +/-- The budgeted step grows the configuration by at most the same constant as a plain step: when +the machine has halted it grows by nothing at all. -/ +lemma budgetStep_size_le [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) + (halting : Q → Bool) (c : UCfg Q S) : + (DataEncode.encode (budgetStep blank dflt halting c)).size + ≤ (DataEncode.encode c).size + stepGrowth (Q := Q) blank := by + unfold budgetStep + cases uHalt halting c + · simpa using uStep_size_le blank dflt c + · simp + +omit [BEq (Q × S)] in +lemma budgetListSize (p : List Unit × UCfg Q S) : + (DataEncode.encode (budgetList p)).size ≤ (DataEncode.encode p).size := by + obtain ⟨fuel, c⟩ := p + have h : (DataEncode.encode ((fuel, c) : List Unit × UCfg Q S)).size + = (DataEncode.encode fuel).size + (DataEncode.encode c).size + 2 := + DataEncode.size_pair _ _ + change (DataEncode.encode fuel).size ≤ _ + omega + +/-- **A certificate for a budgeted run.** No termination hypothesis is needed: the budget on the +input bounds the trip count, so the accumulator bound `n + n * stepGrowth blank` follows from the +per-step growth alone. -/ +def uRunBudgetBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) + (halting : Q → Bool) : + Bounds (foldFun budgetList budgetInit (budgetFoldStep blank dflt halting)) := + Bounds.fold + ((Bounds.fst : Bounds (Prod.fst : List Unit × UCfg Q S → List Unit)).congr rfl) + ((Bounds.snd : Bounds (Prod.snd : List Unit × UCfg Q S → UCfg Q S)).congr rfl) + ((Bounds.comp + (Bounds.ite (uHaltBounds halting) (Bounds.id : Bounds (id : UCfg Q S → UCfg Q S)) + (uStepBounds blank dflt)) + (Bounds.fst : Bounds (Prod.fst : UCfg Q S × Unit → UCfg Q S))).congr rfl) + (fun n => n + n * stepGrowth (Q := Q) blank) + (fun _ _ h => Nat.add_le_add h (Nat.mul_le_mul h (le_refl _))) + (fun p j => by + obtain ⟨fuel, c⟩ := p + rw [foldAcc_budget] + have hp : (DataEncode.encode ((fuel, c) : List Unit × UCfg Q S)).size + = (DataEncode.encode fuel).size + (DataEncode.encode c).size + 2 := + DataEncode.size_pair _ _ + have hlen := DataEncode.length_le_size fuel + have h1 := size_iterate_le (f := budgetStep blank dflt halting) + (stepGrowth (Q := Q) blank) (budgetStep_size_le blank dflt halting) + (fuel.take j).length c + have h2 : (fuel.take j).length + ≤ (DataEncode.encode ((fuel, c) : List Unit × UCfg Q S)).size := by + rw [List.length_take] + omega + have h3 : (fuel.take j).length * stepGrowth (Q := Q) blank + ≤ (DataEncode.encode ((fuel, c) : List Unit × UCfg Q S)).size + * stepGrowth (Q := Q) blank := + Nat.mul_le_mul_right _ h2 + omega) + +/-! ## Variant 2: returning the number of steps + +The same loop, but the accumulator carries a counter alongside the configuration, so the result +reports how many steps were taken. The counter is kept in **unary** — a `List Unit` — which is +what makes incrementing it a `Bounds.cons` and so keeps this file free of new assumptions. A +binary counter would need a `Bounds` certificate for `Nat.succ`; `NatSucc` is that example, but +its certificate is a `Prop`-level `PolyTimeLinSpace` and would have to be strengthened to +`Bounds` first. -/ + +/-- A configuration together with the number of steps taken so far, in unary. -/ +abbrev CCfg (Q S : Type) := List Unit × UCfg Q S + +/-- The counting step: tick the counter and take one universal step. -/ +def countStep (blank : S) (dflt : Instr Q S) (x : CCfg Q S) : CCfg Q S := + (() :: x.1, uStep blank dflt x.2) + +/-- The counting loop stops exactly when the underlying one does. -/ +def countHalt (halting : Q → Bool) (x : CCfg Q S) : Bool := uHalt halting x.2 + +/-- Start with an empty counter. -/ +def countInit (c : UCfg Q S) : CCfg Q S := ([], c) + +/-- How much a counting step can grow the encoding: the configuration's growth, plus the two +cells of one more unary tick. -/ +def countGrowth [Fintype Q] [Fintype S] (blank : S) : ℕ := stepGrowth (Q := Q) blank + 2 + +lemma countStep_size_le [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) (x : CCfg Q S) : + (DataEncode.encode (countStep blank dflt x)).size + ≤ (DataEncode.encode x).size + countGrowth (Q := Q) blank := by + obtain ⟨cnt, c⟩ := x + have h1 : (DataEncode.encode (countStep blank dflt (cnt, c))).size + = ((DataEncode.encode (() : Unit)).size + (DataEncode.encode cnt).size) + + (DataEncode.encode (uStep blank dflt c)).size + 2 := by + rw [show countStep blank dflt (cnt, c) = (() :: cnt, uStep blank dflt c) from rfl, + DataEncode.size_pair, DataEncode.size_cons] + have h2 : (DataEncode.encode ((cnt, c) : CCfg Q S)).size + = (DataEncode.encode cnt).size + (DataEncode.encode c).size + 2 := + DataEncode.size_pair _ _ + have h3 := uStep_size_le blank dflt c + have h4 := DataEncode.size_unit () + unfold countGrowth + omega + +def countStepBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) : + Bounds (countStep blank dflt) := + (Bounds.pair + (Bounds.cons (Bounds.const (() : Unit)) + (Bounds.fst : Bounds (Prod.fst : CCfg Q S → List Unit))) + (Bounds.comp (uStepBounds blank dflt) + (Bounds.snd : Bounds (Prod.snd : CCfg Q S → UCfg Q S)))).congr rfl + +def countHaltBounds [Fintype Q] (halting : Q → Bool) : Bounds (countHalt (S := S) halting) := + (Bounds.comp (uHaltBounds halting) + (Bounds.snd : Bounds (Prod.snd : CCfg Q S → UCfg Q S))).congr rfl + +def countInitBounds : Bounds (countInit : UCfg Q S → CCfg Q S) := + (Bounds.pair (Bounds.const ([] : List Unit)) + (Bounds.id : Bounds (id : UCfg Q S → UCfg Q S))).congr rfl + +/-- **A certificate for a run that reports its own step count.** The output is the pair of the +step count, in unary, and the halting configuration. -/ +def uRunCountBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) (halting : Q → Bool) + (out : UCfg Q S → CCfg Q S) (steps : UCfg Q S → ℕ) + (h_out : ∀ c, out c = (countStep blank dflt)^[steps c] (countInit c)) + (h_halt : ∀ c, countHalt halting ((countStep blank dflt)^[steps c] (countInit c)) = true) + (h_first : ∀ c j, j < steps c → + countHalt halting ((countStep blank dflt)^[j] (countInit c)) = false) + (N : ℕ → ℕ) (hN_mono : Monotone N) + (hN : ∀ c, steps c ≤ N (DataEncode.encode c).size) : + Bounds out := + Bounds.while countInitBounds (countHaltBounds halting) (countStepBounds blank dflt) steps + h_out h_halt h_first + N (fun n => n + 4 + N n * countGrowth (Q := Q) blank) hN_mono + (fun _ _ h => Nat.add_le_add (Nat.add_le_add h (le_refl 4)) + (Nat.mul_le_mul (hN_mono h) (le_refl _))) + hN + (fun c j hj => by + have hinit : (DataEncode.encode (countInit c)).size + = (DataEncode.encode ([] : List Unit)).size + (DataEncode.encode c).size + 2 := + DataEncode.size_pair _ _ + have hnil : (DataEncode.encode ([] : List Unit)).size = 2 := by + change (Data.l []).size = 2 + simp [Data.size] + have h1 := size_iterate_le (f := countStep blank dflt) (countGrowth (Q := Q) blank) + (countStep_size_le blank dflt) j (countInit c) + have h2 : j * countGrowth (Q := Q) blank + ≤ N (DataEncode.encode c).size * countGrowth (Q := Q) blank := + Nat.mul_le_mul_right _ (le_trans hj (hN c)) + omega) + +end Universal + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean new file mode 100644 index 0000000000..c802c56738 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean @@ -0,0 +1,132 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Bounds + +/-! +# Complexity of `List.foldl` + +The main theorem of the development, plus its `Bounds` packaging. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +/-! ## 4. Complexity of `foldl` -/ + +variable {α β γ : Type} [DataEncode α] [DataEncode β] [DataEncode γ] + +/-- The accumulator reached after `j` steps of folding `step` over `list a`, starting from +`init a`. The point of naming it is that the hypothesis of `foldl_computableUpTo` has to bound +*all* intermediate accumulators, not just the final result. -/ +def foldAcc (list : α → List β) (init : α → γ) (step : γ → β → γ) (a : α) (j : ℕ) : γ := + ((list a).take j).foldl step (init a) + +/-- The function computed by folding `step` over `list`, starting from `init`. -/ +def foldFun (list : α → List β) (init : α → γ) (step : γ → β → γ) (a : α) : γ := + (list a).foldl step (init a) + +omit [DataEncode α] [DataEncode β] [DataEncode γ] in +/-- The final accumulator is the value of the fold. -/ +lemma foldAcc_length (list : α → List β) (init : α → γ) (step : γ → β → γ) (a : α) : + foldAcc list init step a (list a).length = foldFun list init step a := by + simp [foldAcc, foldFun] + +/-- +**Complexity of `foldl` on multi-tape Turing machines.** + +Assume that + +* `list : α → List β` is computable in time `t_l` and space `s_l`, +* `init : α → γ` is computable in time `t_i` and space `s_i`, +* `step : γ → β → γ`, seen as a function of the pair `(accumulator, element)`, is computable in + time `t_s` and space `s_s`, both monotone, +* the encoded list `list a` has size at most `S n`, and +* every intermediate accumulator `foldAcc list init step a j` has encoded size at most `A n`, + +where `n` is the encoded size of the input `a`. Then `fun a => (list a).foldl step (init a)` is +computable by some multi-tape Turing machine in + +* time `t_l n + t_i n + S n * t_s (A n + S n + 2)` — the list and the initial accumulator are + produced once, and then at most `S n` iterations each cost one `step` on an argument of size at + most `A n + S n + 2`; +* space `s_l n + s_i n + s_s (A n + S n + 2) + A n + S n` — the list and the current accumulator + have to be kept, plus the workspace of a single `step` invocation, which is reused across + iterations. + +Both up to the slack of `ComputableUpTo`: a polynomial in time, a constant factor in space. +-/ +theorem foldl_computableUpTo + (list : α → List β) (init : α → γ) (step : γ → β → γ) + (t_l s_l t_i s_i t_s s_s A S : ℕ → ℕ) + (h_list : ComputableUpTo list t_l s_l) + (h_init : ComputableUpTo init t_i s_i) + (h_step : ComputableUpTo (Function.uncurry step) t_s s_s) + (h_t_s : Monotone t_s) (h_s_s : Monotone s_s) + (h_listSize : ∀ a : α, + (DataEncode.encode (list a)).size ≤ S (DataEncode.encode a).size) + (h_accSize : ∀ (a : α) (j : ℕ), + (DataEncode.encode (foldAcc list init step a j)).size ≤ A (DataEncode.encode a).size) : + ComputableUpTo (foldFun list init step) + (fun n => t_l n + t_i n + S n * t_s (A n + S n + 2)) + (fun n => s_l n + s_i n + s_s (A n + S n + 2) + A n + S n) := by + sorry + +/-- **`foldl` as a `Bounds` combinator.** + +Every other combinator derives its bounds from those of its parts. `fold` is the only one that +needs something a human has to supply: `A`, a uniform bound on the encoded size of the +intermediate accumulators. Making that the single explicit argument is the point of the +packaging — it isolates the one creative step of a fold complexity argument. -/ +def Bounds.fold {list : α → List β} {init : α → γ} {step : γ → β → γ} + (hl : Bounds list) (hi : Bounds init) (hs : Bounds (Function.uncurry step)) + (A : ℕ → ℕ) (hA_mono : Monotone A) + (hA : ∀ (a : α) (j : ℕ), + (DataEncode.encode (foldAcc list init step a j)).size ≤ A (DataEncode.encode a).size) : + Bounds (foldFun list init step) where + time n := hl.time n + hi.time n + hl.outSize n * hs.time (A n + hl.outSize n + 2) + space n := hl.space n + hi.space n + hs.space (A n + hl.outSize n + 2) + A n + hl.outSize n + outSize := A + time_mono := by + intro a b h + have h1 := hl.time_mono h + have h2 := hi.time_mono h + have h3 := hl.outSize_mono h + have h4 : hs.time (A a + hl.outSize a + 2) ≤ hs.time (A b + hl.outSize b + 2) := + hs.time_mono (by have := hA_mono h; omega) + exact Nat.add_le_add (Nat.add_le_add h1 h2) (Nat.mul_le_mul h3 h4) + space_mono := fun _ _ h => + Nat.add_le_add + (Nat.add_le_add + (Nat.add_le_add (Nat.add_le_add (hl.space_mono h) (hi.space_mono h)) + (hs.space_mono (Nat.add_le_add + (Nat.add_le_add (hA_mono h) (hl.outSize_mono h)) (le_refl 2)))) + (hA_mono h)) + (hl.outSize_mono h) + outSize_mono := hA_mono + computes := sorry + out_le a := by + rw [← foldAcc_length list init step a] + exact hA a _ + +/-- A `foldl` whose step ignores the element is iteration: the list only supplies a trip count. +This is how a step *budget* on the input turns into a bounded run. -/ +lemma foldl_const_iterate {β γ : Type} (f : γ → γ) (l : List β) (c : γ) : + l.foldl (fun x _ => f x) c = f^[l.length] c := by + induction l generalizing c with + | nil => simp + | cons _ l ih => simp [ih, Function.iterate_succ_apply] + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean new file mode 100644 index 0000000000..f6121307ea --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean @@ -0,0 +1,272 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Bounds +public import Mathlib.Data.Fintype.Lattice + +/-! +# Elementary building blocks + +The base of the combinator algebra. Every declaration here is a `Bounds` certificate whose +`computes` field is `sorry`: no concrete multi-tape Turing machine is constructed anywhere in this +development, so the machines are assumed and only their *resource discipline* is checked. + +That split is deliberate and is worth stating precisely: in each definition below the +`time`/`space`/`outSize` bounds, their monotonicity and the output-size proof are all genuinely +proved. The single assumed thing is the existence of the machine. + +## The primitives + +* `Bounds.id`, `Bounds.const`, `Bounds.fst`, `Bounds.snd`, `Bounds.headD`, `Bounds.tail` — no + work tape at all: the machine copies part of its read-only input to its write-only output tape, + and neither is charged for space. Skipping over a subtree needs a nesting counter, which is free + precisely because `DataEncode.depth` bounds the depth by a constant of the type — see the + `DataEncode` docstring. +* `Bounds.ofFintype` — a function between finite types is a lookup: constant time and no work tape. +* `Bounds.comp` — sequential composition; the intermediate result has to be materialised on a work + tape, which is why `f`'s output size appears in the *space* bound. +* `Bounds.pair` — fan-out: run both machines on the same input and juxtapose their outputs. Time + and space both **sum** (both results must coexist), unlike the `max` that a case split would + give. +* `Bounds.cons` — fan-out fused with a cons, matching the `cons (h t : Prog)` node of + [issue #611](https://github.com/leanprover/cslib/issues/611). This, rather than the unary + `α × List α → List α`, is the primitive worth assuming: the unary version is `pair` followed by + deleting one bracket, and falls out as `Bounds.consUncurried`. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +variable {α β γ : Type} [DataEncode α] [DataEncode β] [DataEncode γ] + +namespace Bounds + +/-- **Identity.** Copy the read-only input to the write-only output; no work tape is used, and +neither of those tapes is charged for space. -/ +def id : Bounds (_root_.id : α → α) where + time n := n + 2 + space _ := 0 + outSize n := n + time_mono := fun _ _ h => Nat.add_le_add_right h 2 + space_mono := monotone_const + outSize_mono := monotone_id + computes := sorry + out_le _ := le_refl _ + +/-- **Constants.** Emit a fixed value; its size is a constant of the machine. -/ +def const (b : β) : Bounds (fun _ : α => b) where + time _ := (DataEncode.encode b).size + 2 + space _ := 0 + outSize _ := (DataEncode.encode b).size + time_mono := monotone_const + space_mono := monotone_const + outSize_mono := monotone_const + computes := sorry + out_le _ := le_refl _ + +/-- **First projection.** Copy the first child of the input node to the output. -/ +def fst : Bounds (Prod.fst : α × β → α) where + time n := n + 2 + space _ := 0 + outSize n := n + time_mono := fun _ _ h => Nat.add_le_add_right h 2 + space_mono := monotone_const + outSize_mono := monotone_id + computes := sorry + out_le p := by + have h : (DataEncode.encode p).size + = (DataEncode.encode p.1).size + (DataEncode.encode p.2).size + 2 := + DataEncode.size_pair _ _ + omega + +/-- **Second projection.** -/ +def snd : Bounds (Prod.snd : α × β → β) where + time n := n + 2 + space _ := 0 + outSize n := n + time_mono := fun _ _ h => Nat.add_le_add_right h 2 + space_mono := monotone_const + outSize_mono := monotone_id + computes := sorry + out_le p := by + have h : (DataEncode.encode p).size + = (DataEncode.encode p.1).size + (DataEncode.encode p.2).size + 2 := + DataEncode.size_pair _ _ + omega + +/-- **Functions on a finite domain.** There are finitely many inputs, so the machine can decide +the answer from its state alone: constant time, no work tape. -/ +def ofFintype [Fintype α] (f : α → β) : Bounds f where + time _ := (Finset.univ.sup fun a : α => + (DataEncode.encode a).size + (DataEncode.encode (f a)).size) + 2 + space _ := 0 + outSize _ := Finset.univ.sup fun a : α => (DataEncode.encode (f a)).size + time_mono := monotone_const + space_mono := monotone_const + outSize_mono := monotone_const + computes := sorry + out_le a := Finset.le_sup (f := fun x : α => (DataEncode.encode (f x)).size) + (Finset.mem_univ a) + +/-- **Sequential composition.** Run the machine for `f`, materialise its output on a work tape, +then run the machine for `g` on it — which is why `f`'s output size is charged to the space +bound and `g`'s bounds are evaluated at it. -/ +def comp {f : α → β} {g : β → γ} (hg : Bounds g) (hf : Bounds f) : Bounds (g ∘ f) where + time n := hf.time n + hg.time (hf.outSize n) + space n := hf.space n + hg.space (hf.outSize n) + hf.outSize n + outSize n := hg.outSize (hf.outSize n) + time_mono := by + intro a b h + exact Nat.add_le_add (hf.time_mono h) (hg.time_mono (hf.outSize_mono h)) + space_mono := by + intro a b h + exact Nat.add_le_add + (Nat.add_le_add (hf.space_mono h) (hg.space_mono (hf.outSize_mono h))) + (hf.outSize_mono h) + outSize_mono := by + intro a b h + exact hg.outSize_mono (hf.outSize_mono h) + computes := sorry + out_le a := le_trans (hg.out_le (f a)) (hg.outSize_mono (hf.out_le a)) + +/-- **Fan-out.** Run both machines on the same input and pair the results. Both outputs have to +coexist on tape, so time and space add rather than taking a maximum. -/ +def pair {f : α → β} {g : α → γ} (hf : Bounds f) (hg : Bounds g) : + Bounds (fun a => (f a, g a)) where + time n := hf.time n + hg.time n + hf.outSize n + hg.outSize n + space n := hf.space n + hg.space n + hf.outSize n + hg.outSize n + outSize n := hf.outSize n + hg.outSize n + 2 + time_mono := fun _ _ h => + Nat.add_le_add (Nat.add_le_add (Nat.add_le_add (hf.time_mono h) (hg.time_mono h)) + (hf.outSize_mono h)) (hg.outSize_mono h) + space_mono := fun _ _ h => + Nat.add_le_add (Nat.add_le_add (Nat.add_le_add (hf.space_mono h) (hg.space_mono h)) + (hf.outSize_mono h)) (hg.outSize_mono h) + outSize_mono := fun _ _ h => + Nat.add_le_add (Nat.add_le_add (hf.outSize_mono h) (hg.outSize_mono h)) (le_refl 2) + computes := sorry + out_le a := by + rw [DataEncode.size_pair] + have := hf.out_le a + have := hg.out_le a + omega + +/-- **Fan-out fused with a cons.** This is the `cons (h t : Prog)` node of issue #611, and the +list primitive worth assuming: the unary `α × List α → List α` is this composed with the +projections. Note the output size is *exactly* the sum — a cons cell costs no bracket of its +own beyond what the two parts already pay. -/ +def cons {f : α → β} {g : α → List β} (hf : Bounds f) (hg : Bounds g) : + Bounds (fun a => f a :: g a) where + time n := hf.time n + hg.time n + hf.outSize n + hg.outSize n + space n := hf.space n + hg.space n + hf.outSize n + hg.outSize n + outSize n := hf.outSize n + hg.outSize n + time_mono := fun _ _ h => + Nat.add_le_add (Nat.add_le_add (Nat.add_le_add (hf.time_mono h) (hg.time_mono h)) + (hf.outSize_mono h)) (hg.outSize_mono h) + space_mono := fun _ _ h => + Nat.add_le_add (Nat.add_le_add (Nat.add_le_add (hf.space_mono h) (hg.space_mono h)) + (hf.outSize_mono h)) (hg.outSize_mono h) + outSize_mono := fun _ _ h => Nat.add_le_add (hf.outSize_mono h) (hg.outSize_mono h) + computes := sorry + out_le a := by + rw [DataEncode.size_cons] + have := hf.out_le a + have := hg.out_le a + omega + +/-- **Head with a default.** Copy the first child of the input node to the output, or the +default if there is none. The default's size is a constant of the machine, hence the `+` in the +output bound. -/ +def headD (a₀ : α) : Bounds (fun xs : List α => xs.head?.getD a₀) where + time n := n + 2 + space _ := 0 + outSize n := n + (DataEncode.encode a₀).size + time_mono := fun _ _ h => Nat.add_le_add_right h 2 + space_mono := monotone_const + outSize_mono := fun _ _ h => Nat.add_le_add_right h _ + computes := sorry + out_le xs := by + cases xs with + | nil => simp + | cons x xs => + have h := DataEncode.size_mem_le (xs := x :: xs) (x := x) (by simp) + simpa using by omega + +/-- **`Option.getD`.** An `Option` encodes exactly like a list of length at most one, so this is +the same bracket surgery as `headD`. -/ +def optionGetD (a₀ : α) : Bounds (fun o : Option α => o.getD a₀) where + time n := n + 2 + space _ := 0 + outSize n := n + (DataEncode.encode a₀).size + time_mono := fun _ _ h => Nat.add_le_add_right h 2 + space_mono := monotone_const + outSize_mono := fun _ _ h => Nat.add_le_add_right h _ + computes := sorry + out_le o := by + cases o with + | none => simp + | some x => + have h : (DataEncode.encode (some x)).size = (DataEncode.encode x).size + 2 := + DataEncode.size_some x + simpa using by omega + +/-- **Tail.** Drop the first child of the input node. -/ +def tail : Bounds (fun xs : List α => xs.tail) where + time n := n + 2 + space _ := 0 + outSize n := n + time_mono := fun _ _ h => Nat.add_le_add_right h 2 + space_mono := monotone_const + outSize_mono := monotone_id + computes := sorry + out_le xs := by + cases xs with + | nil => simp + | cons x xs => + have h := DataEncode.size_cons x xs + have h2 := Data.two_le_size (DataEncode.encode x) + simpa using by omega + +/-- **Branching.** Evaluate the condition, then whichever branch it selects. `cond` is used +rather than `if` so that no `Decidable` instance travels with the statement. -/ +def ite {c : α → Bool} {f g : α → β} (hc : Bounds c) (hf : Bounds f) (hg : Bounds g) : + Bounds (fun a => cond (c a) (f a) (g a)) where + time n := hc.time n + hf.time n + hg.time n + space n := hc.space n + hf.space n + hg.space n + outSize n := hf.outSize n + hg.outSize n + time_mono := fun _ _ h => + Nat.add_le_add (Nat.add_le_add (hc.time_mono h) (hf.time_mono h)) (hg.time_mono h) + space_mono := fun _ _ h => + Nat.add_le_add (Nat.add_le_add (hc.space_mono h) (hf.space_mono h)) (hg.space_mono h) + outSize_mono := fun _ _ h => Nat.add_le_add (hf.outSize_mono h) (hg.outSize_mono h) + computes := sorry + out_le a := by + have h1 := hf.out_le a + have h2 := hg.out_le a + cases c a + · simp only [Bool.cond_false]; omega + · simp only [Bool.cond_true]; omega + +/-- The unary cons, derived: pair up the two projections and cons them. -/ +def consUncurried : Bounds (fun p : β × List β => p.1 :: p.2) := + cons fst snd + +/-- Swapping the components of a pair, derived from fan-out and the projections. -/ +def swap : Bounds (fun p : α × β => (p.2, p.1)) := + pair snd fst + +end Bounds + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/While.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/While.lean new file mode 100644 index 0000000000..f5b43ee398 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/While.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Bounds + +/-! +# Unbounded iteration + +`Bounds.while` is the companion of `Bounds.fold` for loops whose trip count is not given by a +list. It is what a universal machine needs: it runs the simulated machine until it halts, rather +than for a number of steps read off the input. + +## The shape of the statement + +A `while` loop is partial, so the combinator cannot simply be handed `p` and `f` and produce a +function. Instead the *result* `out` is supplied together with an iteration count `steps`, and +three hypotheses pin them down: `out a` is the `steps a`-th iterate, the test fires there, and it +did not fire earlier. Nothing is assumed about inputs on which the loop diverges, because there +are none — `steps` is total. + +Two further arguments are the ones a human must invent, exactly as `A` is for `Bounds.fold`: + +* `N`, a bound on the number of iterations; +* `A`, a bound on the encoded size of every intermediate value. + +## Why space does not multiply + +The time bound carries a factor of `N` — every iteration re-runs the test and the body. The space +bound does **not**: the work tapes of one iteration are reused by the next, so the space cost is +the largest single iteration rather than their sum. That asymmetry is the whole reason a loop can +run for exponentially many steps in polynomial space, and it is the point of +[issue #611](https://github.com/leanprover/cslib/issues/611)'s remark that for `fold` and `while_` +"tapes from earlier iterations are re-used, so the space usage is the max over all iterations". +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +variable {α γ : Type} [DataEncode α] [DataEncode γ] + +/-- **Unbounded iteration.** Starting from `init a`, apply `f` until the test `p` holds; the +result is `out a`, reached after `steps a` iterations. + +Time is `init` plus one test-and-body per iteration; space is `init` plus a *single* iteration +plus the largest intermediate value, because iterations reuse each other's tapes. -/ +def Bounds.while {p : γ → Bool} {f : γ → γ} {init out : α → γ} + (hi : Bounds init) (hp : Bounds p) (hf : Bounds f) + (steps : α → ℕ) + (h_out : ∀ a, out a = f^[steps a] (init a)) + (h_halt : ∀ a, p (f^[steps a] (init a)) = true) + (h_first : ∀ a j, j < steps a → p (f^[j] (init a)) = false) + (N A : ℕ → ℕ) (hN_mono : Monotone N) (hA_mono : Monotone A) + (hN : ∀ a, steps a ≤ N (DataEncode.encode a).size) + (hA : ∀ (a : α) (j : ℕ), j ≤ steps a → + (DataEncode.encode (f^[j] (init a))).size ≤ A (DataEncode.encode a).size) : + Bounds out where + time n := hi.time n + (N n + 1) * (hp.time (A n) + hf.time (A n)) + space n := hi.space n + hp.space (A n) + hf.space (A n) + A n + outSize := A + time_mono := fun _ _ h => + Nat.add_le_add (hi.time_mono h) + (Nat.mul_le_mul (Nat.add_le_add (hN_mono h) (le_refl 1)) + (Nat.add_le_add (hp.time_mono (hA_mono h)) (hf.time_mono (hA_mono h)))) + space_mono := fun _ _ h => + Nat.add_le_add + (Nat.add_le_add (Nat.add_le_add (hi.space_mono h) (hp.space_mono (hA_mono h))) + (hf.space_mono (hA_mono h))) + (hA_mono h) + outSize_mono := hA_mono + computes := sorry + out_le a := by + rw [h_out a] + exact hA a (steps a) (le_refl _) + +/-- Iterating a function that grows the encoding by at most `C` grows it by at most `j * C`. This +is the standard way to discharge `Bounds.while`'s `A` argument. -/ +lemma size_iterate_le {f : γ → γ} (C : ℕ) + (hf : ∀ c, (DataEncode.encode (f c)).size ≤ (DataEncode.encode c).size + C) + (j : ℕ) (c : γ) : + (DataEncode.encode (f^[j] c)).size ≤ (DataEncode.encode c).size + j * C := by + induction j generalizing c with + | zero => simp + | succ j ih => + rw [Function.iterate_succ_apply] + have h1 := hf c + have h2 := ih (f c) + have h3 : (j + 1) * C = j * C + C := by ring + omega + +end MultiTapeTM + +end Turing From 1f6a976ebc0fa62c8edf938a40cc62332bebf010 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 1 Sep 2026 00:40:36 +0200 Subject: [PATCH 2/8] More results about UTM. --- .../Machines/Turing/MultiTape/Complexity.lean | 8 + .../Turing/MultiTape/Complexity/Encoding.lean | 23 ++ .../Complexity/Examples/InputCursor.lean | 203 ++++++++++++ .../Complexity/Examples/ListUpdate.lean | 291 +++++++++++++++++ .../Complexity/Examples/LookupTable.lean | 98 ++++++ .../Complexity/Examples/MachineDesc.lean | 116 +++++++ .../Complexity/Examples/SimConfig.lean | 296 ++++++++++++++++++ .../Complexity/Examples/SpaceBound.lean | 126 ++++++++ .../Complexity/Examples/TapeStep.lean | 175 +++++++++++ .../Complexity/Examples/TapeView.lean | 251 +++++++++++++++ .../MultiTape/Complexity/Primitives.lean | 12 + 11 files changed, 1599 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/LookupTable.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean index 99ab2ee88f..644e913c3b 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean @@ -15,9 +15,17 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.While public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListIndex public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListMap +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListUpdate public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.NatMul public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Lookup +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.LookupTable +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.MachineDesc public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Tape +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeView +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeStep +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SimConfig +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.InputCursor +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SpaceBound public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Universal public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.NatArith diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean index 2843e8cd13..4f90fc1761 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean @@ -8,6 +8,7 @@ module public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Data public import Mathlib.Data.Nat.Size +public import Mathlib.Data.Sign.Defs /-! # Encoding Lean types into rose trees @@ -216,6 +217,28 @@ instance : DataEncode ℕ where have := foldr_max_le n.bits (Data.depth ∘ Data.ofBit) 3 (fun b _ => hb b) omega +instance (n : ℕ) : DataEncode (Fin n) where + encode i := DataEncode.encode i.val + h_inj := fun _ _ h => Fin.ext (DataEncode.h_inj h) + depth := DataEncode.depth (α := ℕ) + h_depth i := DataEncode.h_depth i.val + +/-- The three head movements of a `MultiTapeTM`, as `none` / `some false` / `some true`. -/ +def signToOptBool : SignType → Option Bool + | .zero => none + | .neg => some false + | .pos => some true + +lemma signToOptBool_injective : Function.Injective signToOptBool := by + intro a b h + cases a <;> cases b <;> simp_all [signToOptBool] + +instance : DataEncode SignType where + encode m := DataEncode.encode (signToOptBool m) + h_inj := fun _ _ h => signToOptBool_injective (DataEncode.h_inj h) + depth := DataEncode.depth (α := Option Bool) + h_depth m := DataEncode.h_depth (signToOptBool m) + /-! ### Encoded sizes The size lemmas below are what complexity proofs actually reason with; nothing downstream should diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean new file mode 100644 index 0000000000..cfca67c4f2 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeView + +/-! +# The input head + +The input tape of a `MultiTapeTM` is not a work tape. Its head is confined to +`Fin (input.length + 2)` and `moveInputPos` **clamps**: an attempt to step off either end produces +no movement, where a work tape would extend with blanks. So the finite stand-in cannot be a +`Tape`; it is a *cursor* into a finite list, whose moves are no-ops at the ends. + +`padded input` is that finite list — a blank, the input, a blank — and `inputSymbol_eq` shows it +is exactly what the machine reads: `Cfg.inputSymbol` is its `inputPos`-th entry. `CursorRepr` then +ties a cursor to a position, and the three lemmas at the end show `cursorRead`, `cursorR` and +`cursorL` implement reading and `moveInputPos` faithfully. + +Everything here is proved. The cursor operations also carry `Bounds` certificates built from the +primitives, so the input head costs the same as a work tape head. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +namespace Simulation + +variable {α : Type} + +/-- A cursor into a *finite* list: the cells before the head in reverse order, and the cells from +the head onwards. Unlike `Tape`, the head never leaves the list — moving off either end does +nothing, which is exactly `moveInputPos`'s clamping. -/ +abbrev Cursor (α : Type) := List α × List α + +/-- The cell under the cursor, or `d` past the end. -/ +def cursorRead (d : α) (c : Cursor α) : α := c.2.head?.getD d + +/-- Move right, unless that would take the head off the end. The default `d` is never read: it is +only there to make the projection total. -/ +def cursorR (d : α) (c : Cursor α) : Cursor α := + cond c.2.tail.isEmpty c (c.2.head?.getD d :: c.1, c.2.tail) + +/-- Move left, unless that would take the head off the start. -/ +def cursorL (d : α) (c : Cursor α) : Cursor α := + cond c.1.isEmpty c (c.1.tail, c.1.head?.getD d :: c.2) + +/-! ### Certificates, from the primitives -/ + +variable [DataEncode α] + +/-- Reading the cursor is taking the head of its second component. -/ +def cursorReadBounds (d : α) : Bounds (cursorRead d) := + (Bounds.comp (Bounds.headD d) + (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))).congr rfl + +/-- Moving right: test whether the tail is empty, then either do nothing or shift one cell. -/ +def cursorRBounds (d : α) : Bounds (cursorR d) := + (Bounds.ite + (Bounds.comp Bounds.isEmpty + (Bounds.comp Bounds.tail (Bounds.snd : Bounds (Prod.snd : Cursor α → List α)))) + (Bounds.id : Bounds (id : Cursor α → Cursor α)) + (Bounds.pair + (Bounds.cons (Bounds.comp (Bounds.headD d) + (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))) + (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) + (Bounds.comp Bounds.tail + (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))))).congr rfl + +/-- Moving left. -/ +def cursorLBounds (d : α) : Bounds (cursorL d) := + (Bounds.ite + (Bounds.comp Bounds.isEmpty (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) + (Bounds.id : Bounds (id : Cursor α → Cursor α)) + (Bounds.pair + (Bounds.comp Bounds.tail (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) + (Bounds.cons (Bounds.comp (Bounds.headD d) + (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) + (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))))).congr rfl + +/-! ### The input tape as a finite list -/ + +/-- The input tape of a `MultiTapeTM` as a finite list: a blank cell, the input, a blank cell. +Entry `i` is what the machine reads when `inputPos = i`. -/ +def padded {Symbol : Type} (input : List Symbol) : List (Option Symbol) := + none :: (input.map some ++ [none]) + +@[simp] +lemma padded_length {Symbol : Type} (input : List Symbol) : + (padded input).length = input.length + 2 := by + simp [padded] + +/-- **What the machine reads is the padded input at the head position.** -/ +lemma inputSymbol_eq {k : ℕ} {Symbol State : Type} {input : List Symbol} + (cfg : Cfg k Symbol State input) : + cfg.inputSymbol = ((padded input)[cfg.inputPos.val]?).getD none := by + have hlt := cfg.inputPos.isLt + unfold Cfg.inputSymbol + split_ifs with h₁ h₂ + · have hval : cfg.inputPos.val = 0 := by rw [h₁]; rfl + simp [padded, hval] + · simp [padded, h₂] + · have hne0 : cfg.inputPos.val ≠ 0 := fun hz => h₁ (Fin.ext hz) + obtain ⟨m, hm⟩ : ∃ m, cfg.inputPos.val = m + 1 := ⟨cfg.inputPos.val - 1, by omega⟩ + have hmlt : m < input.length := by omega + have hmlt' : m < (List.map (some : Symbol → Option Symbol) input).length := by + simpa using hmlt + simp [padded, hm, List.getElem?_append_left hmlt', List.getElem?_map, + List.getElem?_eq_getElem hmlt] + +/-! ### A cursor represents a head position -/ + +/-- `c` is a cursor on the padded input with its head at `pos`. -/ +def CursorRepr {Symbol : Type} (input : List Symbol) (c : Cursor (Option Symbol)) + (pos : Fin (input.length + 2)) : Prop := + c.1.length = pos.val ∧ c.1.reverse ++ c.2 = padded input + +lemma CursorRepr.length_add {Symbol : Type} {input : List Symbol} + {c : Cursor (Option Symbol)} {pos : Fin (input.length + 2)} + (h : CursorRepr input c pos) : c.1.length + c.2.length = input.length + 2 := by + have := congrArg List.length h.2 + simpa using this + +/-- **Reading the cursor is reading the input tape.** -/ +lemma cursorRead_eq {Symbol : Type} {input : List Symbol} {c : Cursor (Option Symbol)} + {pos : Fin (input.length + 2)} (h : CursorRepr input c pos) : + cursorRead none c = ((padded input)[pos.val]?).getD none := by + have hlen : c.1.reverse.length = pos.val := by simpa using h.1 + rw [← h.2, List.getElem?_append_right (by omega), hlen] + simp [cursorRead, List.head?_eq_getElem?] + +/-- **Moving the cursor right implements `moveInputPos … .pos`.** -/ +lemma cursorR_repr {Symbol : Type} {input : List Symbol} {c : Cursor (Option Symbol)} + {pos : Fin (input.length + 2)} (d : Option Symbol) (h : CursorRepr input c pos) : + CursorRepr input (cursorR d c) (moveInputPos pos .pos) := by + have h1 := h.1 + have h2 := h.2 + have hsum := h.length_add + have hpos := pos.isLt + match hc : c.2 with + | [] => + exfalso + rw [hc] at hsum + simp at hsum + omega + | [x] => + have hval : pos.val = input.length + 1 := by + rw [hc] at hsum; simp at hsum; omega + have hp : pos = (⟨input.length + 1, by omega⟩ : Fin (input.length + 2)) := Fin.ext hval + have hmove : moveInputPos pos SignType.pos = pos := by + rw [hp]; exact moveInputPos_rightBoundary + have hfix : cursorR d c = c := by simp [cursorR, hc] + rw [hmove, hfix] + exact h + | x :: y :: r => + have hne : pos.val ≠ input.length + 1 := by + rw [hc] at hsum; simp at hsum; omega + have hstep : cursorR d c = (x :: c.1, y :: r) := by simp [cursorR, hc] + rw [moveInputPos_pos_of_ne_right pos hne, hstep] + rw [hc] at h2 + exact ⟨by simp [h1], by simpa using h2⟩ + +/-- **Moving the cursor left implements `moveInputPos … .neg`.** -/ +lemma cursorL_repr {Symbol : Type} {input : List Symbol} {c : Cursor (Option Symbol)} + {pos : Fin (input.length + 2)} (d : Option Symbol) (h : CursorRepr input c pos) : + CursorRepr input (cursorL d c) (moveInputPos pos .neg) := by + have h1 := h.1 + have h2 := h.2 + match hc : c.1 with + | [] => + have hval : pos.val = 0 := by rw [hc] at h1; simpa using h1.symm + have hp : pos = 0 := Fin.ext (by simpa using hval) + have hmove : moveInputPos pos SignType.neg = pos := by + rw [hp]; exact moveInputPos_leftBoundary + have hfix : cursorL d c = c := by simp [cursorL, hc] + rw [hmove, hfix] + exact h + | x :: l => + have hne : pos ≠ 0 := by + intro hp + rw [hc, hp] at h1 + simp at h1 + have hstep : cursorL d c = (l, x :: c.2) := by simp [cursorL, hc] + rw [moveInputPos_neg_of_ne_left pos hne, hstep] + rw [hc] at h1 h2 + refine ⟨?_, ?_⟩ + · simp at h1 ⊢; omega + · simpa using h2 + +end Simulation + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean new file mode 100644 index 0000000000..def611f8c6 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean @@ -0,0 +1,291 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives + +/-! +# Example: `fun (i, v, l) => l.set i v` +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +/-! ## 6. Worked example: `fun (i, v, l) => l.set i v` + +Updating a list at an index is a fold that combines the two ideas of the previous examples: the +countdown of `ListIndex` decides *when* to write, and the in-order append of `ListMap` builds the +result. The accumulator is a triple — the countdown, the value to write (carried along unchanged, +because `step` sees only the accumulator and the current element), and the output produced so far. + +As in `ListIndex` the counter is stored *offset by one*: `init` produces `i + 1` and the new value +is emitted exactly when the counter reads `1`. Truncated subtraction then pins the counter at `0`, +which the guard never matches again, so at most one position is overwritten. Past the end of the +list nothing fires at all, which is precisely the `l.set i v = l` behaviour of `List.set` for +out-of-range indices. + +Appending with `acc ++ [·]` rather than consing keeps the output in order, so no final reverse is +needed; only the projection out of the triple remains, which is again `ComputableUpTo.comp`. + +The accumulator is bounded by `A n = 2 * n + 6` rather than `n + O(1)`: the value `v` occurs twice +in it — once as the carried value and once inside the output list — and `v` can be as large as the +whole input. That is still linear, so the space bound is still linear. +-/ + +namespace ListUpdate + +variable {α : Type} + +/-- The list the update fold runs over: the list component of the input. -/ +def updateList (p : ℕ × α × List α) : List α := p.2.2 + +/-- The initial accumulator: the index offset by one, the value to write, and an empty output. -/ +def updateInit (p : ℕ × α × List α) : ℕ × α × List α := (p.1 + 1, p.2.1, []) + +/-- One step of the update fold: count down, carry the value along, and append either the new +value (exactly when the counter reads `1`) or the element that was already there. -/ +def updateStep (acc : ℕ × α × List α) (x : α) : ℕ × α × List α := + (acc.1 - 1, acc.2.1, acc.2.2 ++ [if acc.1 = 1 then acc.2.1 else x]) + +/-- The final projection: the output list is the third component of the accumulator. -/ +def updateOut (acc : ℕ × α × List α) : List α := acc.2.2 + +/-- **List update as a fold**: run `updateStep` over the list and project the output out. -/ +def updateFun (p : ℕ × α × List α) : List α := + updateOut (foldFun updateList updateInit updateStep p) + +/-! ### Correctness of the fold -/ + +/-- Once the counter has reached `0` the guard never fires again, so the remaining elements are +copied across unchanged. -/ +lemma foldl_zero (l : List α) (v : α) (out : List α) : + l.foldl updateStep (0, v, out) = (0, v, out ++ l) := by + induction l generalizing out with + | nil => simp + | cons x xs ih => + rw [List.foldl_cons] + change xs.foldl updateStep (0, v, out ++ [if (0 : ℕ) = 1 then v else x]) + = (0, v, out ++ x :: xs) + rw [ite_eq_right (by omega), ih (out ++ [x])] + simp + +/-- **The fold writes the new value at exactly the right position.** The counter starts offset by +one, so starting from `i + 1` the output is the input list with position `i` replaced. -/ +lemma foldl_out (l : List α) (i : ℕ) (v : α) (out : List α) : + (l.foldl updateStep (i + 1, v, out)).2.2 = out ++ l.set i v := by + induction l generalizing i out with + | nil => simp + | cons x xs ih => + rw [List.foldl_cons] + cases i with + | zero => + change (xs.foldl updateStep (0 + 1 - 1, v, out ++ [if 0 + 1 = 1 then v else x])).2.2 + = out ++ (x :: xs).set 0 v + rw [ite_eq_left rfl] + change (xs.foldl updateStep (0, v, out ++ [v])).2.2 = out ++ (x :: xs).set 0 v + rw [foldl_zero] + simp + | succ k => + change (xs.foldl updateStep (k + 1 + 1 - 1, v, out ++ [if k + 1 + 1 = 1 then v else x])).2.2 + = out ++ (x :: xs).set (k + 1) v + rw [ite_eq_right (by omega), show k + 1 + 1 - 1 = k + 1 from by omega, ih k (out ++ [x])] + simp + +/-- **The fold computes `List.set`.** -/ +lemma foldFun_out (p : ℕ × α × List α) : + (foldFun updateList updateInit updateStep p).2.2 = p.2.2.set p.1 p.2.1 := by + obtain ⟨i, v, l⟩ := p + change (l.foldl updateStep (i + 1, v, [])).2.2 = l.set i v + rw [foldl_out] + simp + +/-- **Correctness of `updateFun`.** -/ +lemma updateFun_eq (p : ℕ × α × List α) : updateFun p = p.2.2.set p.1 p.2.1 := + foldFun_out p + +/-! ### Size bookkeeping -/ + +/-- The counter never exceeds its initial value. -/ +lemma foldl_fst_le (l : List α) (m : ℕ) (v : α) (out : List α) : + (l.foldl updateStep (m, v, out)).1 ≤ m := by + induction l generalizing m out with + | nil => simp + | cons x xs ih => + rw [List.foldl_cons] + change (xs.foldl updateStep (m - 1, v, out ++ [if m = 1 then v else x])).1 ≤ m + exact le_trans (ih _ _) (Nat.sub_le _ _) + +/-- The value to be written is carried along unchanged. -/ +lemma foldl_snd_fst (l : List α) (m : ℕ) (v : α) (out : List α) : + (l.foldl updateStep (m, v, out)).2.1 = v := by + induction l generalizing m out with + | nil => simp + | cons x xs ih => + rw [List.foldl_cons] + change (xs.foldl updateStep (m - 1, v, out ++ [if m = 1 then v else x])).2.1 = v + exact ih _ _ + +private lemma size_take_le [DataEncode α] (l : List α) (j : ℕ) : + (DataEncode.encode (l.take j)).size ≤ (DataEncode.encode l).size := by + have h := sum_map_take_le l (fun x => (DataEncode.encode x).size) j + rw [DataEncode.size_list, DataEncode.size_list] + omega + +private lemma size_set_le [DataEncode α] (l : List α) (i : ℕ) (v : α) : + (DataEncode.encode (l.set i v)).size + ≤ (DataEncode.encode l).size + (DataEncode.encode v).size := by + induction l generalizing i with + | nil => simp + | cons x xs ih => + cases i with + | zero => + rw [List.set_cons_zero, DataEncode.size_cons, DataEncode.size_cons] + omega + | succ k => + rw [List.set_cons_succ, DataEncode.size_cons, DataEncode.size_cons] + have := ih k + omega + +private lemma size_triple [DataEncode α] (q : ℕ × α × List α) : + (DataEncode.encode q).size + = (DataEncode.encode q.1).size + (DataEncode.encode q.2.1).size + + (DataEncode.encode q.2.2).size + 4 := by + have h1 : (DataEncode.encode q).size + = (DataEncode.encode q.1).size + (DataEncode.encode q.2).size + 2 := + DataEncode.size_pair _ _ + have h2 : (DataEncode.encode q.2).size + = (DataEncode.encode q.2.1).size + (DataEncode.encode q.2.2).size + 2 := + DataEncode.size_pair _ _ + omega + +private lemma accSizeCore [DataEncode α] (l : List α) (i j : ℕ) (v : α) : + (DataEncode.encode ((l.take j).foldl updateStep (i + 1, v, []))).size + ≤ (DataEncode.encode i).size + 2 * (DataEncode.encode v).size + + (DataEncode.encode l).size + 10 := by + have hsplit := size_triple ((l.take j).foldl updateStep (i + 1, v, [])) + have h1 : (DataEncode.encode ((l.take j).foldl updateStep (i + 1, v, [])).1).size + ≤ (DataEncode.encode i).size + 6 := + le_trans (DataEncode.size_nat_mono (foldl_fst_le _ _ _ _)) (DataEncode.size_nat_succ i) + have h2 : (DataEncode.encode ((l.take j).foldl updateStep (i + 1, v, [])).2.1).size + = (DataEncode.encode v).size := by rw [foldl_snd_fst] + have h3 : ((l.take j).foldl updateStep (i + 1, v, [])).2.2 = (l.take j).set i v := by + rw [foldl_out] + simp + have h4 : (DataEncode.encode ((l.take j).foldl updateStep (i + 1, v, [])).2.2).size + ≤ (DataEncode.encode l).size + (DataEncode.encode v).size := by + rw [h3] + exact le_trans (size_set_le _ _ _) (Nat.add_le_add_right (size_take_le l j) _) + omega + +/-- The list folded over is a component of the input, so it is no bigger: `S n = n`. -/ +lemma listSize [DataEncode α] (p : ℕ × α × List α) : + (DataEncode.encode (updateList p)).size ≤ (DataEncode.encode p).size := by + obtain ⟨i, v, l⟩ := p + have hp := size_triple ((i, v, l) : ℕ × α × List α) + change (DataEncode.encode l).size ≤ (DataEncode.encode ((i, v, l) : ℕ × α × List α)).size + simp only at hp + omega + +/-- **The accumulator stays linear in the input: `A n = 2 * n + 6`.** + +The counter is at most `i + 1`, whose encoding costs at most six more than that of `i`; the +carried value is `v` itself; and the output so far is a prefix of the list with one entry replaced +by `v`, hence at most the list plus one more copy of `v`. It is that second copy of `v` — which +may be as large as the whole input — that forces the factor of two. -/ +lemma accSize [DataEncode α] (p : ℕ × α × List α) (j : ℕ) : + (DataEncode.encode (foldAcc updateList updateInit updateStep p j)).size + ≤ 2 * (DataEncode.encode p).size + 6 := by + obtain ⟨i, v, l⟩ := p + have hacc : foldAcc updateList updateInit updateStep (i, v, l) j + = (l.take j).foldl updateStep (i + 1, v, []) := rfl + have hp := size_triple ((i, v, l) : ℕ × α × List α) + have hc := accSizeCore l i j v + simp only at hp + rw [hacc] + omega + +/-- The output of the fold is an accumulator, so it obeys the same bound: `S_f n = 2 * n + 6`. -/ +lemma foldOutSize [DataEncode α] (p : ℕ × α × List α) : + (DataEncode.encode (foldFun updateList updateInit updateStep p)).size + ≤ 2 * (DataEncode.encode p).size + 6 := by + rw [← foldAcc_length updateList updateInit updateStep p] + exact accSize p _ + +/-! ### The complexity statement -/ + +/-- +**Updating a list at an index runs in polynomial time and linear space.** + +Given that the three ingredients of the fold — taking the list component, building the initial +accumulator, and one countdown-and-append step — as well as the final projection are each +computable in polynomial time and linear space, so is `fun (i, v, l) => l.set i v`. + +Unfolded, the composed bounds are time `3n² + 12n + 6` and space `12n + 26` in the encoded input +size `n`, which `ComputableUpTo.absorb` restates as "polynomial, linear". +-/ +theorem listUpdate_polyTimeLinSpace [DataEncode α] + (h_list : PolyTimeLinSpace (updateList (α := α))) + (h_init : PolyTimeLinSpace (updateInit (α := α))) + (h_step : PolyTimeLinSpace (Function.uncurry (updateStep (α := α)))) + (h_out : PolyTimeLinSpace (updateOut (α := α))) : + PolyTimeLinSpace (fun p : ℕ × α × List α => p.2.2.set p.1 p.2.1) := by + -- The fold itself: `S n = n`, `A n = 2n + 6`, hence step arguments of size at most `3n + 8`. + have h_fold := foldl_computableUpTo updateList updateInit updateStep + (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) (fun n => n) + (fun n => 2 * n + 6) (fun n => n) + h_list h_init h_step monotone_id monotone_id listSize accSize + -- Project the output list out of the accumulator. + have h_comp := ComputableUpTo.comp (S_f := fun n => 2 * n + 6) h_fold h_out + monotone_id monotone_id (foldOutSize (α := α)) + have h_eq : (updateOut ∘ foldFun updateList updateInit updateStep) + = fun p : ℕ × α × List α => p.2.2.set p.1 p.2.1 := funext fun p => updateFun_eq p + rw [h_eq] at h_comp + -- Absorb the composed closed form into "polynomial time, linear space": + -- time `3n² + 12n + 6 ≤ 3 * (n + n + 2)²`, space `12n + 26 ≤ 26 * (n + 1)`. + refine h_comp.absorb 3 2 26 (fun n => ?_) (fun n => ?_) + · nlinarith [sq_nonneg n] + · omega + +/-! ### The same result in the `Bounds` algebra -/ + +/-- Taking the list component is two projections. -/ +def listBounds [DataEncode α] : Bounds (updateList (α := α)) := + Bounds.congr + (Bounds.comp (Bounds.snd : Bounds (Prod.snd : α × List α → List α)) + (Bounds.snd : Bounds (Prod.snd : ℕ × α × List α → α × List α))) rfl + +/-- Projecting the output list out of the accumulator is the same two projections. -/ +def outBounds [DataEncode α] : Bounds (updateOut (α := α)) := + Bounds.congr + (Bounds.comp (Bounds.snd : Bounds (Prod.snd : α × List α → List α)) + (Bounds.snd : Bounds (Prod.snd : ℕ × α × List α → α × List α))) rfl + +/-- **List update in the `Bounds` algebra.** + +The same result as `listUpdate_polyTimeLinSpace`, built compositionally: the two projections are +primitives, so only the initial accumulator and the step have to be assumed, and the accumulator +bound `A n = 2 * n + 6` is the single creative input to `Bounds.fold`. -/ +def updateBounds [DataEncode α] (hinit : Bounds (updateInit (α := α))) + (hstep : Bounds (Function.uncurry (updateStep (α := α)))) : + Bounds (fun p : ℕ × α × List α => p.2.2.set p.1 p.2.1) := + Bounds.congr + (Bounds.comp outBounds + (Bounds.fold listBounds hinit hstep (fun n => 2 * n + 6) + (fun _ _ h => Nat.add_le_add_right (Nat.mul_le_mul_left 2 h) 6) accSize)) + (funext fun p => updateFun_eq p) + +end ListUpdate + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/LookupTable.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/LookupTable.lean new file mode 100644 index 0000000000..2bfb660e92 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/LookupTable.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Lookup + +/-! +# Faithfulness of tabulated lookup tables + +A universal machine carries the transition function of the machine it simulates as data: an +association list built by tabulating that function over a list of its arguments. Consulting the +table is then `Lookup.lookupFn`, and what the simulation needs is that consulting it gives back +exactly what applying the original function would have given. + +That is the content of `firstMatch_map_of_mem`: if the keys of a tabulated table are pairwise +distinct — the key function `g` is injective on the tabulated list — then looking up `g x` +returns `some (h x)`. Injectivity is what rules out an earlier entry shadowing `x`'s own. + +The `Fintype` corollary is the shape a tabulation actually takes: the table lists *every* +argument, so `Finset.univ.toList` is the list being tabulated over and no membership side +condition survives. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +namespace Lookup + +/-! ### Tabulated tables are faithful -/ + +/-- **Looking up a tabulated entry returns the tabulated value.** In a table obtained by +tabulating `fun w => (g w, h w)` over `l`, the first entry whose key is `g x` is `x`'s own, so +its value is `h x`. The hypothesis is injectivity of `g` on `l`: without it an earlier element +sharing `x`'s key would shadow it. -/ +lemma firstMatch_map_of_mem {K V W : Type} [BEq K] [LawfulBEq K] + (l : List W) (g : W → K) (h : W → V) + (hinj : ∀ x ∈ l, ∀ y ∈ l, g x = g y → x = y) + (x : W) (hx : x ∈ l) : + firstMatch (g x) (l.map fun w => (g w, h w)) = some (h x) := by + induction l with + | nil => simp at hx + | cons w l ih => + simp only [List.map_cons, firstMatch] + cases hb : (g w == g x) with + | true => + have hgw : g w = g x := eq_of_beq hb + have hw : w = x := hinj w List.mem_cons_self x hx hgw + rw [Bool.cond_true, hw] + | false => + rw [Bool.cond_false] + have hne : g w ≠ g x := fun hgw => by simp [hgw] at hb + have hxl : x ∈ l := by + rcases List.mem_cons.mp hx with rfl | hxl + · exact absurd rfl hne + · exact hxl + exact ih (fun a ha b hbm => hinj a (List.mem_cons_of_mem _ ha) b + (List.mem_cons_of_mem _ hbm)) hxl + +/-- The same statement for `lookupFn`, the fold that a machine actually runs. -/ +lemma lookupFn_map_of_mem {K V W : Type} [BEq K] [LawfulBEq K] + (l : List W) (g : W → K) (h : W → V) + (hinj : ∀ x ∈ l, ∀ y ∈ l, g x = g y → x = y) + (x : W) (hx : x ∈ l) : + lookupFn (l.map (fun w => (g w, h w)), g x) = some (h x) := by + rw [lookupFn_eq] + exact firstMatch_map_of_mem l g h hinj x hx + +/-! ### Tabulating over a finite type -/ + +/-- Tabulating `h` over *all* of a finite type, keyed by an injective `g`, gives a table in which +every key lookup succeeds with the tabulated value. This is the form a universal machine's +encoded transition table takes: the argument type is finite, so the table is complete and the +membership hypothesis of `firstMatch_map_of_mem` discharges itself. -/ +lemma firstMatch_map_univ_toList {K V W : Type} [BEq K] [LawfulBEq K] [Fintype W] + (g : W → K) (hg : Function.Injective g) (h : W → V) (x : W) : + firstMatch (g x) (Finset.univ.toList.map fun w => (g w, h w)) = some (h x) := + firstMatch_map_of_mem _ g h (fun _ _ _ _ hab => hg hab) x + (Finset.mem_toList.mpr (Finset.mem_univ x)) + +/-- The `Fintype` tabulation lemma, phrased for `lookupFn`. -/ +lemma lookupFn_map_univ_toList {K V W : Type} [BEq K] [LawfulBEq K] [Fintype W] + (g : W → K) (hg : Function.Injective g) (h : W → V) (x : W) : + lookupFn ((Finset.univ.toList.map fun w => (g w, h w) : Table K V), g x) = some (h x) := by + rw [lookupFn_eq] + exact firstMatch_map_univ_toList g hg h x + +end Lookup + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean new file mode 100644 index 0000000000..b0bbc8e55c --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.LookupTable + +/-! +# An untyped description of a multi-tape machine + +A `MultiTapeTM k Symbol State` is a *typed* object: its transition function ranges over `Fin k`, +over `Symbol` and over `State`, so a term mentioning it is already committed to one particular +number of work tapes, one alphabet and one state set. A universal machine cannot be committed in +that way — it has to accept, as data on its input, the description of an arbitrary machine. + +This file therefore replaces every one of those types by `ℕ`. A state is its index, a tape symbol +is `Option ℕ` (with `none` the blank), and the work-head tuple `Fin k → Option Symbol` becomes a +plain `List`. The resulting types `UKey` and `UOut` are built solely from `ℕ`, `Option`, `List`, +`Prod` and `SignType`, so they inherit `DataEncode` from `Encoding` with no new instance, and — +this is the point of being untyped — a *single* value of type `UTable` can describe a machine for +any `k`, any alphabet size and any state count. One universal machine can interpret them all. + +The description itself, `desc`, is the transition function tabulated over its (finite) domain: +`Lookup.Table`. What the simulation needs from it is faithfulness, `lookupFn_desc`: consulting the +table at `keyOf q a w` returns exactly `outOf (tm.tr q a w)`. That follows from +`Lookup.lookupFn_map_univ_toList` once `keyOf` is known to be injective, which is +`keyOf_injective`: erasing the `Fin` bounds loses no information, because the components are +recovered by `Fin.val_injective` and `List.ofFn_inj`. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +namespace MachineDesc + +/-! ### The untyped types -/ + +/-- An untyped tape symbol: an index into the alphabet, with `none` the blank. -/ +abbrev USym := Option ℕ + +/-- An untyped key of the transition table: the state, the input symbol and the symbols under the +work heads. -/ +abbrev UKey := ℕ × USym × List USym + +/-- An untyped action on one work tape: optionally a symbol to write, then a head movement. -/ +abbrev UAction := Option USym × SignType + +/-- An untyped transition output: the input head's movement, the actions on the work tapes, the +symbol to output and the successor state (`none` to halt). -/ +abbrev UOut := SignType × List UAction × USym × Option ℕ + +/-- An untyped machine description: the transition function as an association list. -/ +abbrev UTable := Lookup.Table UKey UOut + +/-! ### Erasing the types -/ + +/-- The untyped key of a state, an input symbol and a tuple of work-head symbols. -/ +def keyOf {k sym state : ℕ} (q : Fin state) (a : Option (Fin sym)) + (w : Fin k → Option (Fin sym)) : UKey := + (q.val, a.map Fin.val, (List.ofFn w).map (Option.map Fin.val)) + +/-- The untyped form of a transition output. -/ +def outOf {k sym state : ℕ} (o : TransitionOut k (Fin sym) (Fin state)) : UOut := + (o.inputMove, + (List.ofFn o.workActions).map (fun p => (p.1.map (Option.map Fin.val), p.2)), + o.outS.map Fin.val, + o.q'.map Fin.val) + +/-- **The description of a machine**: its transition function tabulated over the whole (finite) +domain, keyed by `keyOf`. -/ +noncomputable def desc {k sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) : UTable := + Finset.univ.toList.map fun x : Fin state × Option (Fin sym) × (Fin k → Option (Fin sym)) => + (keyOf x.1 x.2.1 x.2.2, outOf (tm.tr x.1 x.2.1 x.2.2)) + +/-! ### Faithfulness -/ + +/-- **Erasing the types loses nothing.** The key of a transition argument determines that +argument, so no two entries of `desc` share a key. -/ +lemma keyOf_injective {k sym state : ℕ} : + Function.Injective + (fun x : Fin state × Option (Fin sym) × (Fin k → Option (Fin sym)) => + keyOf x.1 x.2.1 x.2.2) := by + rintro ⟨q₁, a₁, w₁⟩ ⟨q₂, a₂, w₂⟩ h + simp only [keyOf, Prod.mk.injEq] at h + obtain ⟨hq, ha, hw⟩ := h + have hq' : q₁ = q₂ := Fin.val_injective hq + have ha' : a₁ = a₂ := Option.map_injective Fin.val_injective ha + have hw' : w₁ = w₂ := + List.ofFn_inj.mp (List.map_injective_iff.mpr (Option.map_injective Fin.val_injective) hw) + subst hq' + subst ha' + subst hw' + rfl + +/-- **The description is faithful.** Looking a key up in `desc tm` returns exactly the untyped +form of what `tm.tr` returns on the corresponding arguments — so a machine that interprets the +description takes the same steps as `tm`. -/ +lemma lookupFn_desc {k sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (q : Fin state) (a : Option (Fin sym)) (w : Fin k → Option (Fin sym)) : + Lookup.lookupFn (desc tm, keyOf q a w) = some (outOf (tm.tr q a w)) := + Lookup.lookupFn_map_univ_toList + (g := fun x : Fin state × Option (Fin sym) × (Fin k → Option (Fin sym)) => + keyOf x.1 x.2.1 x.2.2) + keyOf_injective (fun x => outOf (tm.tr x.1 x.2.1 x.2.2)) (q, a, w) + +end MachineDesc + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean new file mode 100644 index 0000000000..857c9a3926 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean @@ -0,0 +1,296 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.InputCursor +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeStep + +/-! +# A finite stand-in for a whole configuration + +`MultiTapeTM.Cfg` is not encodable: its `workTapes` field is a family of *functions* +`ℤ → Option Symbol`. `SimCfg` replaces that family by a list of zippers and the input head by a +cursor, so every component is a finite value and the whole configuration inherits `DataEncode` +from the `Prod`, `List` and `Option` instances — no new instance, no new assumption. + +`Represents` says a stand-in denotes a given real configuration. The two theorems here are the +*observation* half of a step simulation: under `Represents`, the stand-in reads exactly the input +symbol and exactly the work-head symbols that the real machine reads. Since `MultiTapeTM.step` +consults `tm.tr` on precisely those two, the same transition fires on both sides. + +The *update* half — that carrying out that transition on the stand-in denotes the updated +configuration — is assembled from lemmas already proved elsewhere: `cursorR_repr`/`cursorL_repr` +for the input head (including `moveInputPos`'s clamping), and `tapeFun_applyAction` for each work +tape. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +namespace Simulation + +open RoseTreeMachine + +/-- A finite stand-in for a configuration: the state, a cursor into the padded input, one zipper +per work tape, and the output produced so far. Every component is finite, so this is encodable +where `Cfg` is not. -/ +abbrev SimCfg (sym state : ℕ) := + Option (Fin state) × Cursor (Option (Fin sym)) × List (Tape (Option (Fin sym))) × List (Fin sym) + +/-- The zipper the stand-in holds for work tape `i`. -/ +def workZipper {sym state : ℕ} (sc : SimCfg sym state) (i : ℕ) : Tape (Option (Fin sym)) := + (sc.2.2.1[i]?).getD ([], []) + +/-- `sc` denotes the configuration `cfg`: same state, the cursor sits where the input head does, +each zipper denotes the corresponding work tape at its head position, and the outputs agree. -/ +def Represents {k sym state : ℕ} {inp : List (Fin sym)} + (sc : SimCfg sym state) (cfg : Cfg k (Fin sym) (Fin state) inp) : Prop := + sc.1 = cfg.state + ∧ CursorRepr inp sc.2.1 cfg.inputPos + ∧ sc.2.2.1.length = k + ∧ (∀ i : Fin k, cfg.workTapes i = tapeFun none (workZipper sc i.val) (cfg.workTapePos i)) + ∧ sc.2.2.2 = cfg.output + +/-- **The stand-in reads the input symbol the machine reads.** -/ +lemma Represents.inputSymbol {k sym state : ℕ} {inp : List (Fin sym)} + {sc : SimCfg sym state} {cfg : Cfg k (Fin sym) (Fin state) inp} + (h : Represents sc cfg) : + cursorRead none sc.2.1 = cfg.inputSymbol := by + rw [cursorRead_eq h.2.1, inputSymbol_eq] + +/-- **The stand-in reads the work-head symbols the machine reads.** -/ +lemma Represents.workSymbols {k sym state : ℕ} {inp : List (Fin sym)} + {sc : SimCfg sym state} {cfg : Cfg k (Fin sym) (Fin state) inp} + (h : Represents sc cfg) (i : Fin k) : + read none (workZipper sc i.val) = cfg.workTapeSymbols i := by + have hw := h.2.2.2.1 i + unfold Cfg.workTapeSymbols + rw [hw, tapeFun_self] + +/-- **The stand-in sees the same transition argument as the machine**, hence the very same +transition fires: `MultiTapeTM.step` consults `tm.tr` on exactly the state, input symbol and +work-head symbols that `Represents` pins down. -/ +lemma Represents.tr_eq {k sym state : ℕ} {inp : List (Fin sym)} + {sc : SimCfg sym state} {cfg : Cfg k (Fin sym) (Fin state) inp} + (h : Represents sc cfg) (tm : MultiTapeTM k (Fin sym) (Fin state)) (q : Fin state) : + tm.tr q (cursorRead none sc.2.1) (fun i => read none (workZipper sc i.val)) + = tm.tr q cfg.inputSymbol cfg.workTapeSymbols := by + rw [h.inputSymbol] + congr 1 + funext i + exact h.workSymbols i + +/-! ### The update half: one simulated step -/ + +/-- Move the input cursor according to a `SignType`. -/ +def moveCursor {α : Type} (blank : α) (m : SignType) (c : Cursor α) : Cursor α := + match m with + | .zero => c + | .neg => cursorL blank c + | .pos => cursorR blank c + +@[simp] lemma moveCursor_zero {α : Type} (blank : α) (c : Cursor α) : + moveCursor blank SignType.zero c = c := rfl + +@[simp] lemma moveCursor_neg {α : Type} (blank : α) (c : Cursor α) : + moveCursor blank SignType.neg c = cursorL blank c := rfl + +@[simp] lemma moveCursor_pos {α : Type} (blank : α) (c : Cursor α) : + moveCursor blank SignType.pos c = cursorR blank c := rfl + +/-- **Moving the cursor implements `moveInputPos`**, clamping included. -/ +lemma cursorMove_repr {Symbol : Type} {input : List Symbol} {c : Cursor (Option Symbol)} + {pos : Fin (input.length + 2)} (d : Option Symbol) (m : SignType) + (h : CursorRepr input c pos) : + CursorRepr input (moveCursor d m c) (moveInputPos pos m) := by + cases m with + | zero => simpa [moveCursor] using h + | neg => exact cursorL_repr d h + | pos => exact cursorR_repr d h + +/-- One step of the simulated machine on the finite stand-in. (Named `cfgStep` to avoid +clashing with `Simulation.simStep`, which steps a machine with a *fixed* transition function.) -/ +def cfgStep {k sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (sc : SimCfg sym state) : SimCfg sym state := + match sc.1 with + | none => sc + | some q => + let o := tm.tr q (cursorRead none sc.2.1) (fun i : Fin k => read none (workZipper sc i.val)) + (o.q', + moveCursor none o.inputMove sc.2.1, + List.ofFn (fun i : Fin k => applyAction none (o.workActions i) (workZipper sc i.val)), + sc.2.2.2 ++ o.outS.toList) + +/-! ### Field-by-field projections of `MultiTapeTM.step` + +`MultiTapeTM.step` is a `match` on `cfg.state` returning an anonymous structure, so reasoning +about one of its fields by unfolding it inside a larger proof drags the whole record along — and +`simp` then normalises `tm.tr` to the raw projection on one side of the goal only. These five +lemmas do the unfolding once each, in a form already phrased with `tm.tr`. They belong next to +`step` itself (cslib has `step_output` in the same spirit); anything else that simulates `step` +will want them. -/ + +variable {k : ℕ} {Symbol State : Type} {input : List Symbol} + +lemma step_state (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) + (q : State) (hq : cfg.state = some q) : + (tm.step cfg).state = (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).q' := by + unfold MultiTapeTM.step + rw [hq] + +lemma step_inputPos (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) + (q : State) (hq : cfg.state = some q) : + (tm.step cfg).inputPos + = moveInputPos cfg.inputPos (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).inputMove := by + unfold MultiTapeTM.step + rw [hq] + +lemma step_workTapePos (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) + (q : State) (hq : cfg.state = some q) (i : Fin k) : + (tm.step cfg).workTapePos i + = cfg.workTapePos i + ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workActions i).2 := by + unfold MultiTapeTM.step + rw [hq] + +lemma step_workTapes (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) + (q : State) (hq : cfg.state = some q) (i : Fin k) : + (tm.step cfg).workTapes i + = stepTape (cfg.workTapes i) (cfg.workTapePos i) + ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workActions i).1 := by + cases ha : ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workActions i).1 with + | none => simp [MultiTapeTM.step, stepTape, hq, ha] + | some s => simp [MultiTapeTM.step, stepTape, hq, ha] + +lemma step_output' (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State input) + (q : State) (hq : cfg.state = some q) : + (tm.step cfg).output + = cfg.output ++ (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).outS.toList := by + unfold MultiTapeTM.step + rw [hq] + +/-- **The finite step simulates `MultiTapeTM.step`.** + +Every field is accounted for: the state and output directly, the input head through +`cursorMove_repr` (so `moveInputPos`'s clamping is respected), and each work tape through +`tapeFun_applyAction`. Because `Represents.tr_eq` shows the stand-in sees exactly the arguments the +machine passes to `tm.tr`, the *same* transition drives both sides. -/ +lemma Represents.step {sym state : ℕ} {inp : List (Fin sym)} + {sc : SimCfg sym state} {cfg : Cfg k (Fin sym) (Fin state) inp} + (tm : MultiTapeTM k (Fin sym) (Fin state)) (h : Represents sc cfg) : + Represents (cfgStep tm sc) (tm.step cfg) := by + obtain ⟨hstate, hcur, hlen, hwork, hout⟩ := h + cases hq : sc.1 with + | none => + have hcfg : cfg.state = none := by rw [← hstate, hq] + have h1 : cfgStep tm sc = sc := by simp [cfgStep, hq] + have h2 : tm.step cfg = cfg := MultiTapeTM.step_of_halt hcfg + rw [h1, h2] + exact ⟨hstate, hcur, hlen, hwork, hout⟩ + | some q => + have hcfg : cfg.state = some q := by rw [← hstate, hq] + have htr : tm.tr q (cursorRead none sc.2.1) + (fun i : Fin k => read none (workZipper sc i.val)) + = tm.tr q cfg.inputSymbol cfg.workTapeSymbols := + Represents.tr_eq ⟨hstate, hcur, hlen, hwork, hout⟩ tm q + have hsim : cfgStep tm sc = + ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).q', + moveCursor none (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).inputMove sc.2.1, + List.ofFn (fun i : Fin k => + applyAction none ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workActions i) + (workZipper sc i.val)), + sc.2.2.2 ++ (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).outS.toList) := by + simp only [cfgStep, hq, htr] + refine ⟨?_, ?_, ?_, ?_, ?_⟩ + · rw [hsim, step_state tm cfg q hcfg] + · rw [hsim, step_inputPos tm cfg q hcfg] + exact cursorMove_repr none _ hcur + · rw [hsim] + simp + · intro i + have hz : workZipper (cfgStep tm sc) i.val + = applyAction none ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workActions i) + (workZipper sc i.val) := by + rw [hsim] + unfold workZipper + rw [List.getElem?_ofFn, dite_eq_left i.isLt] + simp + rw [hz, step_workTapePos tm cfg q hcfg i, tapeFun_applyAction, ← hwork i, + step_workTapes tm cfg q hcfg i] + · rw [hsim, step_output' tm cfg q hcfg] + simp only [] + rw [hout] + +/-! ### Assembly: a finite computation reproduces the whole run -/ + +/-- The finite stand-in for the initial configuration: the start state, the cursor just past the +left blank, one empty zipper per work tape, and no output. -/ +def initSimCfg {sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (inp : List (Fin sym)) : SimCfg sym state := + (some tm.q₀, ([none], inp.map some ++ [none]), + List.replicate k (([], []) : Tape (Option (Fin sym))), []) + +/-- A fresh zipper denotes the all-blank tape. -/ +lemma tapeFun_empty {α : Type} (blank : α) (p : ℤ) : + tapeFun blank (([], []) : Tape α) p = fun _ => blank := by + funext z + by_cases h : z < p <;> simp [tapeFun, h] + +/-- **The finite stand-in denotes the initial configuration.** -/ +lemma initRepresents {sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (inp : List (Fin sym)) : + Represents (initSimCfg tm inp) (tm.initCfg inp) := by + refine ⟨rfl, ⟨?_, ?_⟩, ?_, ?_, rfl⟩ + · simp [initSimCfg] + · simp [initSimCfg, padded] + · simp [initSimCfg] + · intro i + have hz : workZipper (initSimCfg tm inp) i.val = (([], []) : Tape (Option (Fin sym))) := by + unfold workZipper initSimCfg + simp [i.isLt] + rw [hz, tapeFun_empty] + simp + +/-- **`Represents` is preserved along a whole run.** -/ +lemma Represents.runFrom {sym state : ℕ} {inp : List (Fin sym)} + {sc : SimCfg sym state} {cfg : Cfg k (Fin sym) (Fin state) inp} + (tm : MultiTapeTM k (Fin sym) (Fin state)) (h : Represents sc cfg) (t : ℕ) : + Represents ((cfgStep tm)^[t] sc) (tm.runFrom cfg t) := by + induction t with + | zero => simpa using h + | succ t ih => + rw [Function.iterate_succ_apply', MultiTapeTM.runFrom_succ_eq_step'] + exact Represents.step tm ih + +/-- **The simulation theorem.** Iterating the finite step from the finite initial configuration +denotes the machine's real configuration after the same number of steps — for every number of +tapes, alphabet size and state count. Both sides of `Represents` are ordinary values here: the +left one is encodable, the right one is not. -/ +theorem simulates {sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (inp : List (Fin sym)) (t : ℕ) : + Represents ((cfgStep tm)^[t] (initSimCfg tm inp)) (tm.runFrom (tm.initCfg inp) t) := + Represents.runFrom tm (initRepresents tm inp) t + +/-- **The simulated run produces the machine's output.** -/ +theorem simulates_output {sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (inp : List (Fin sym)) (t : ℕ) : + ((cfgStep tm)^[t] (initSimCfg tm inp)).2.2.2 = (tm.runFrom (tm.initCfg inp) t).output := + (simulates tm inp t).2.2.2.2 + +/-- **The simulated run halts exactly when the machine does.** -/ +theorem simulates_state {sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (inp : List (Fin sym)) (t : ℕ) : + ((cfgStep tm)^[t] (initSimCfg tm inp)).1 = (tm.runFrom (tm.initCfg inp) t).state := + (simulates tm inp t).1 + +end Simulation + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean new file mode 100644 index 0000000000..9b051b9947 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeView + +/-! +# The span of a head walk is bounded by the space it uses + +`Extent` measures a zipper by the *span* of the positions its head has covered, while +`MultiTapeTM.spaceUsedByTape` measures a computation by the *number of distinct cells* the head +visited. This file shows the former is bounded by the latter, which is what turns an +`Extent`-based size bound into a bound in the simulated machine's space. + +The two agree because a head moves by at most one cell per step (`workTapePos_step_le`), so the +set of visited positions is an interval: a discrete intermediate value theorem. Without that, a +walk could in principle jump and cover a wide span while visiting few cells. + +The first two results are about arbitrary integer walks and have nothing to do with machines; +`span_le_spaceUsedByTape` specialises them to `MultiTapeTM`. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +namespace Simulation + +/-- **Discrete intermediate value theorem**, increasing form: a walk taking steps of size at most +one attains every value between its endpoints. -/ +lemma exists_eq_of_step {f : ℕ → ℤ} (hstep : ∀ j, |f (j + 1) - f j| ≤ 1) : + ∀ (b a : ℕ), a ≤ b → ∀ y : ℤ, f a ≤ y → y ≤ f b → ∃ j, a ≤ j ∧ j ≤ b ∧ f j = y := by + intro b + induction b with + | zero => + intro a hab y h1 h2 + have ha : a = 0 := by omega + subst ha + exact ⟨0, le_refl _, le_refl _, by omega⟩ + | succ b ih => + intro a hab y h1 h2 + by_cases hcase : y ≤ f b + · rcases Nat.lt_or_ge a (b + 1) with h | h + · obtain ⟨j, hj1, hj2, hj3⟩ := ih a (by omega) y h1 hcase + exact ⟨j, hj1, by omega, hj3⟩ + · have ha : a = b + 1 := by omega + subst ha + exact ⟨b + 1, le_refl _, le_refl _, by omega⟩ + · obtain ⟨hs1, hs2⟩ := abs_le.mp (hstep b) + exact ⟨b + 1, hab, le_refl _, by omega⟩ + +/-- **Discrete intermediate value theorem**, either direction. -/ +lemma exists_eq_between {f : ℕ → ℤ} (hstep : ∀ j, |f (j + 1) - f j| ≤ 1) + {a b : ℕ} (hab : a ≤ b) {y : ℤ} + (h1 : min (f a) (f b) ≤ y) (h2 : y ≤ max (f a) (f b)) : + ∃ j, a ≤ j ∧ j ≤ b ∧ f j = y := by + rcases le_total (f a) (f b) with hf | hf + · rw [min_eq_left hf] at h1 + rw [max_eq_right hf] at h2 + exact exists_eq_of_step hstep b a hab y h1 h2 + · rw [min_eq_right hf] at h1 + rw [max_eq_left hf] at h2 + have hstep' : ∀ j, |(fun j => -f j) (j + 1) - (fun j => -f j) j| ≤ 1 := by + intro j + change |(-f (j + 1)) - (-f j)| ≤ 1 + have hr : (-f (j + 1)) - (-f j) = -(f (j + 1) - f j) := by ring + rw [hr, abs_neg] + exact hstep j + have h1' : (fun j => -f j) a ≤ -y := by change -f a ≤ -y; omega + have h2' : -y ≤ (fun j => -f j) b := by change -y ≤ -f b; omega + obtain ⟨j, hj1, hj2, hj3⟩ := + exists_eq_of_step (f := fun j => -f j) hstep' b a hab (-y) h1' h2' + refine ⟨j, hj1, hj2, ?_⟩ + have hj : -f j = -y := hj3 + omega + +/-- **The span between any two visited positions is bounded by the number of positions visited.** +This is the abstract form of "a zipper is no bigger than the space used". -/ +lemma card_image_ge {f : ℕ → ℤ} (hstep : ∀ j, |f (j + 1) - f j| ≤ 1) (n : ℕ) {a b : ℕ} + (ha : a ≤ n) (hb : b ≤ n) : + (f b - f a).natAbs + 1 ≤ ((Finset.range (n + 1)).image f).card := by + have hsub : Finset.Icc (min (f a) (f b)) (max (f a) (f b)) + ⊆ (Finset.range (n + 1)).image f := by + intro y hy + simp only [Finset.mem_Icc] at hy + rcases le_total a b with h | h + · obtain ⟨j, _, hj2, hj3⟩ := exists_eq_between hstep h hy.1 hy.2 + exact Finset.mem_image.mpr ⟨j, Finset.mem_range.mpr (by omega), hj3⟩ + · have h1' : min (f b) (f a) ≤ y := by rw [min_comm]; exact hy.1 + have h2' : y ≤ max (f b) (f a) := by rw [max_comm]; exact hy.2 + obtain ⟨j, _, hj2, hj3⟩ := exists_eq_between hstep h h1' h2' + exact Finset.mem_image.mpr ⟨j, Finset.mem_range.mpr (by omega), hj3⟩ + have hcard := Finset.card_le_card hsub + rw [Int.card_Icc] at hcard + omega + +/-- **The bridge to cslib's space measure.** For any two moments in a computation, the distance +the head travelled between them is bounded by the number of cells it visited — so an +`Extent`-based size bound is a bound in the simulated machine's *space*, not its running time. -/ +lemma span_le_spaceUsedByTape {k : ℕ} {Symbol State : Type*} + {input : List Symbol} (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) + {a b : ℕ} (ha : a ≤ t) (hb : b ≤ t) : + ((tm.runFrom cfg b).workTapePos i - (tm.runFrom cfg a).workTapePos i).natAbs + 1 + ≤ tm.spaceUsedByTape cfg t i := by + have hstep : ∀ j : ℕ, + |(fun j => (tm.runFrom cfg j).workTapePos i) (j + 1) + - (fun j => (tm.runFrom cfg j).workTapePos i) j| ≤ 1 := by + intro j + change |(tm.runFrom cfg (j + 1)).workTapePos i - (tm.runFrom cfg j).workTapePos i| ≤ 1 + rw [MultiTapeTM.runFrom_succ_eq_step'] + exact MultiTapeTM.workTapePos_step_le _ i + unfold MultiTapeTM.spaceUsedByTape MultiTapeTM.visitedByTapeHead + exact card_image_ge (f := fun j => (tm.runFrom cfg j).workTapePos i) hstep t ha hb + +end Simulation + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean new file mode 100644 index 0000000000..a7064684dd --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeView + +/-! +# One work-tape action + +`MultiTapeTM.step` acts on each work tape by optionally writing under the head and then moving: + +``` +workTapes i := match (workActions i).1 with + | none => cfg.workTapes i + | some s => Function.update (cfg.workTapes i) (cfg.workTapePos i) s +workTapePos i := cfg.workTapePos i + (workActions i).2 +``` + +`stepTape` is that update, and `applyAction` is the same thing on a finite zipper. +`tapeFun_applyAction` proves the two agree under the denotation of `TapeView` — the work-tape half +of a configuration-level simulation. + +The `Extent` lemmas at the end record what the action costs in stored cells: at most one new cell +on the side the head moves towards, and none at all for a write that stays inside the represented +region. That is what keeps a simulation's space tied to the simulated machine's space rather than +to its running time. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +namespace Simulation + +variable {S : Type} + +/-- The update `MultiTapeTM.step` performs on one work tape: write under the head, or leave the +tape alone. -/ +def stepTape (f : ℤ → S) (p : ℤ) (a : Option S) : ℤ → S := + match a with + | none => f + | some s => Function.update f p s + +/-- One work-tape action on a finite zipper: optionally write under the head, then move. -/ +def applyAction (blank : S) (a : Option S × SignType) (t : Tape S) : Tape S := + let t' := match a.1 with + | none => t + | some s => write (t, s) + match a.2 with + | .zero => t' + | .neg => moveL blank t' + | .pos => moveR blank t' + +@[simp] lemma signCast_zero : ((SignType.zero : SignType) : ℤ) = 0 := rfl +@[simp] lemma signCast_neg : ((SignType.neg : SignType) : ℤ) = -1 := rfl +@[simp] lemma signCast_pos : ((SignType.pos : SignType) : ℤ) = 1 := rfl + +@[simp] lemma applyAction_none_zero (blank : S) (t : Tape S) : + applyAction blank (none, SignType.zero) t = t := rfl + +@[simp] lemma applyAction_none_neg (blank : S) (t : Tape S) : + applyAction blank (none, SignType.neg) t = moveL blank t := rfl + +@[simp] lemma applyAction_none_pos (blank : S) (t : Tape S) : + applyAction blank (none, SignType.pos) t = moveR blank t := rfl + +@[simp] lemma applyAction_some_zero (blank : S) (s : S) (t : Tape S) : + applyAction blank (some s, SignType.zero) t = write (t, s) := rfl + +@[simp] lemma applyAction_some_neg (blank : S) (s : S) (t : Tape S) : + applyAction blank (some s, SignType.neg) t = moveL blank (write (t, s)) := rfl + +@[simp] lemma applyAction_some_pos (blank : S) (s : S) (t : Tape S) : + applyAction blank (some s, SignType.pos) t = moveR blank (write (t, s)) := rfl + +/-- **A work-tape action on the zipper implements the one `MultiTapeTM.step` performs.** -/ +lemma tapeFun_applyAction (blank : S) (a : Option S × SignType) (t : Tape S) (p : ℤ) : + tapeFun blank (applyAction blank a t) (p + (a.2 : ℤ)) + = stepTape (tapeFun blank t p) p a.1 := by + obtain ⟨w, m⟩ := a + cases w with + | none => + cases m with + | zero => simp [applyAction, stepTape] + | neg => + have : p + (-1 : ℤ) = p - 1 := by ring + simp only [applyAction, stepTape, signCast_neg, this] + exact tapeFun_moveL blank t p + | pos => + simp only [applyAction, stepTape, signCast_pos] + exact tapeFun_moveR blank t p + | some s => + cases m with + | zero => + simp only [applyAction, stepTape, signCast_zero, add_zero] + exact tapeFun_write blank t p s + | neg => + have h : p + (-1 : ℤ) = p - 1 := by ring + simp only [applyAction, stepTape, signCast_neg, h] + rw [tapeFun_moveL blank (write (t, s)) p] + exact tapeFun_write blank t p s + | pos => + simp only [applyAction, stepTape, signCast_pos] + rw [tapeFun_moveR blank (write (t, s)) p] + exact tapeFun_write blank t p s + +/-! ### What an action costs in stored cells -/ + +/-- **One action stores at most one more cell on each side.** + +The exact new extent depends on the action — a no-op widens nothing, a write covers the cell under +the head, a move covers the cell it steps onto — so the statement is existential in `lo'` and `hi'` +with the widening bounded. That bound is what keeps a simulation's space proportional to the +simulated machine's space rather than to its running time. -/ +lemma Extent.applyAction (blank : S) (a : Option S × SignType) {t : Tape S} {lo p hi : ℤ} + (h : Extent t lo p hi) : + ∃ lo' hi', Extent (Simulation.applyAction blank a t) lo' (p + (a.2 : ℤ)) hi' + ∧ min lo (p - 1) ≤ lo' ∧ lo' ≤ lo ∧ hi ≤ hi' ∧ hi' ≤ max hi (p + 1) := by + obtain ⟨h1, h2, _, _⟩ := id h + obtain ⟨w, m⟩ := a + have hz : p + ((SignType.zero : SignType) : ℤ) = p := by rw [signCast_zero]; ring + have hn : p + ((SignType.neg : SignType) : ℤ) = p - 1 := by rw [signCast_neg]; ring + have hp : p + ((SignType.pos : SignType) : ℤ) = p + 1 := by rw [signCast_pos] + cases w with + | none => + cases m with + | zero => + refine ⟨lo, hi, ?_, by omega, by omega, by omega, by omega⟩ + rw [hz, applyAction_none_zero] + exact h + | neg => + refine ⟨min lo (p - 1), hi, ?_, by omega, by omega, by omega, by omega⟩ + rw [hn, applyAction_none_neg] + exact Extent.moveL blank h + | pos => + refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ + rw [hp, applyAction_none_pos] + exact Extent.moveR blank h + | some s => + have hw : Extent (Simulation.write (t, s)) lo p (max hi (p + 1)) := Extent.write s h + cases m with + | zero => + refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ + rw [hz, applyAction_some_zero] + exact hw + | neg => + refine ⟨min lo (p - 1), max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ + rw [hn, applyAction_some_neg] + exact Extent.moveL blank hw + | pos => + refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ + have hm := Extent.moveR blank hw + have hmax : max (max hi (p + 1)) (p + 1) = max hi (p + 1) := by omega + rw [hmax] at hm + rw [hp, applyAction_some_pos] + exact hm + +/-- The stored span grows by at most two cells per action. -/ +lemma Extent.applyAction_span {lo p hi lo' hi' : ℤ} + (h1 : min lo (p - 1) ≤ lo') (h2 : lo' ≤ lo) (h3 : hi ≤ hi') (h4 : hi' ≤ max hi (p + 1)) + (hlo : lo ≤ p) (hhi : p ≤ hi) : + (hi' - lo').toNat ≤ (hi - lo).toNat + 2 := by + omega + +end Simulation + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean new file mode 100644 index 0000000000..5906820730 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Tape + +/-! +# The zipper really is a Turing machine tape + +`Turing.MultiTapeTM.Cfg` stores each work tape as a *function* `ℤ → Option Symbol`, which is not a +finite value and so cannot be encoded on a tape. This file discharges the gap: a zipper together +with a head position denotes such a function, and the finite tape operations of `Simulation` +implement the real ones exactly. + +`tapeFun blank t p` is the bi-infinite tape denoted by the zipper `t` with its head at `p`. The +four lemmas below say that under this reading + +* `read` is evaluation at the head, +* `write` is `Function.update` at the head — the very operation `MultiTapeTM.step` performs, +* `moveR`/`moveL` shift the head by one and leave the denoted function alone. + +That is the "only finitely many cells are used" assumption, discharged rather than assumed: every +configuration reachable from a finite starting tape is denoted by some zipper. + +## What this does *not* do + +It does not build a universal `MultiTapeTM`. Two things are still missing, and they are of very +different kinds: + +1. **Configuration-level simulation.** Lifting these lemmas from one tape to a whole + `MultiTapeTM.Cfg` — `k` work tapes (a `Fin k`-indexed family, so its finite stand-in is a + vector), the input head's `Fin (n + 2)` position, and the output list — and proving the finite + step commutes with `MultiTapeTM.step`. This is ordinary work: provable, just long. +2. **Existence of the machine.** A statement of the form "there is a `MultiTapeTM` that simulates + every `MultiTapeTM`" cannot be proved from anything in this development, because *no* concrete + multi-tape machine is constructed anywhere in it. It reduces to the same assumed primitives as + every other example — see the status note in `Complexity.lean`. Building one is the real + remaining task, and nothing here shortens it. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine Simulation + +namespace Simulation + +variable {S : Type} + +/-- The bi-infinite tape denoted by a zipper whose head sits at position `p`: the first component +holds the cells strictly left of `p`, nearest first, and the second the cells from `p` rightwards. +Everything beyond either end reads as `blank`. -/ +def tapeFun (blank : S) (t : Tape S) (p : ℤ) : ℤ → S := fun z => + if z < p then (t.1[(p - z - 1).toNat]?).getD blank + else (t.2[(z - p).toNat]?).getD blank + +/-- Reading the zipper is evaluating the denoted tape at the head. -/ +@[simp] +lemma tapeFun_self (blank : S) (t : Tape S) (p : ℤ) : + tapeFun blank t p p = read blank t := by + simp [tapeFun, read, List.head?_eq_getElem?] + +/-- Writing to the zipper is `Function.update` of the denoted tape at the head — which is exactly +what `MultiTapeTM.step` does to `Cfg.workTapes`. -/ +lemma tapeFun_write (blank : S) (t : Tape S) (p : ℤ) (s : S) : + tapeFun blank (write (t, s)) p = Function.update (tapeFun blank t p) p s := by + funext z + rcases lt_trichotomy z p with h | h | h + · have hne : z ≠ p := by omega + simp [tapeFun, write, hne, h] + · subst h + simp [tapeFun, write] + · have hne : z ≠ p := by omega + have hz : ¬ z < p := by omega + obtain ⟨n, hn⟩ : ∃ n : ℕ, (z - p).toNat = n + 1 := ⟨(z - p).toNat - 1, by omega⟩ + simp [tapeFun, write, hne, hz, hn, List.getElem?_tail] + +/-- Moving the head right shifts the position and leaves the denoted tape unchanged. -/ +lemma tapeFun_moveR (blank : S) (t : Tape S) (p : ℤ) : + tapeFun blank (moveR blank t) (p + 1) = tapeFun blank t p := by + funext z + rcases lt_trichotomy z p with h | h | h + · have h1 : z < p + 1 := by omega + have h2 : (p + 1 - z - 1).toNat = (p - z - 1).toNat + 1 := by omega + simp [tapeFun, moveR, h, h1, h2] + · subst h + have h1 : z < z + 1 := by omega + simp [tapeFun, moveR, h1, List.head?_eq_getElem?] + · have h1 : ¬ z < p := by omega + have h2 : ¬ z < p + 1 := by omega + have h3 : (z - p).toNat = (z - (p + 1)).toNat + 1 := by omega + simp [tapeFun, moveR, h1, h2, h3, List.getElem?_tail] + +/-- Moving the head left shifts the position and leaves the denoted tape unchanged. -/ +lemma tapeFun_moveL (blank : S) (t : Tape S) (p : ℤ) : + tapeFun blank (moveL blank t) (p - 1) = tapeFun blank t p := by + funext z + rcases lt_trichotomy z (p - 1) with h | h | h + · have h1 : z < p := by omega + have h3 : (p - z - 1).toNat = (p - 1 - z - 1).toNat + 1 := by omega + simp [tapeFun, moveL, h, h1, h3, List.getElem?_tail] + · have h1 : ¬ z < p - 1 := by omega + have h2 : z < p := by omega + have h3 : (z - (p - 1)).toNat = 0 := by omega + have h4 : (p - z - 1).toNat = 0 := by omega + simp [tapeFun, moveL, h1, h2, h3, h4, List.head?_eq_getElem?] + · have h1 : ¬ z < p - 1 := by omega + have h2 : ¬ z < p := by omega + have h3 : (z - (p - 1)).toNat = (z - p).toNat + 1 := by omega + simp [tapeFun, moveL, h1, h2, h3] + +/-! ### How wide a zipper gets + +A simulation's space bound should be the simulated machine's *space*, not its running time. +`Extent` is what makes that possible: a zipper stores exactly the cells spanned by the positions +its head has occupied, so it grows only when the head reaches ground it has not been on before. +Contrast the crude bound in `Universal`, where the accumulator is charged one growth per step. +-/ + +/-- `Extent t lo p hi` says the zipper `t` has its head at `p` and stores exactly the cells from +`lo` to `hi` inclusive. -/ +def Extent (t : Tape S) (lo p hi : ℤ) : Prop := + lo ≤ p ∧ p ≤ hi ∧ t.1.length = (p - lo).toNat ∧ t.2.length = (hi - p).toNat + +/-- A fresh zipper covers the single cell under the head. -/ +lemma Extent.init : Extent (([], []) : Tape S) 0 0 0 := by + refine ⟨le_refl _, le_refl _, ?_, ?_⟩ <;> simp + +/-- **The number of cells a zipper stores is the span of its extent** — not the number of steps +taken to get there. -/ +lemma Extent.length_eq {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : + t.1.length + t.2.length = (hi - lo).toNat := by + obtain ⟨h1, h2, h3, h4⟩ := h + omega + +/-- Moving right extends the span only if the head was already at its right edge. -/ +lemma Extent.moveR (blank : S) {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : + Extent (Simulation.moveR blank t) lo (p + 1) (max hi (p + 1)) := by + obtain ⟨h1, h2, h3, h4⟩ := h + refine ⟨by omega, by omega, ?_, ?_⟩ + · have e : (Simulation.moveR blank t).1.length = t.1.length + 1 := by simp [Simulation.moveR] + omega + · cases hr : t.2 with + | nil => + have e : (Simulation.moveR blank t).2.length = 0 := by simp [Simulation.moveR, hr] + rw [hr] at h4 + simp only [List.length_nil] at h4 + omega + | cons x rest => + have e : (Simulation.moveR blank t).2.length = rest.length := by simp [Simulation.moveR, hr] + rw [hr] at h4 + simp only [List.length_cons] at h4 + omega + +/-- Moving left extends the span only if the head was already at its left edge. -/ +lemma Extent.moveL (blank : S) {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : + Extent (Simulation.moveL blank t) (min lo (p - 1)) (p - 1) hi := by + obtain ⟨h1, h2, h3, h4⟩ := h + refine ⟨by omega, by omega, ?_, ?_⟩ + · cases hl : t.1 with + | nil => + have e : (Simulation.moveL blank t).1.length = 0 := by simp [Simulation.moveL, hl] + rw [hl] at h3 + simp only [List.length_nil] at h3 + omega + | cons x l' => + have e : (Simulation.moveL blank t).1.length = l'.length := by simp [Simulation.moveL, hl] + rw [hl] at h3 + simp only [List.length_cons] at h3 + omega + · have e : (Simulation.moveL blank t).2.length = t.2.length + 1 := by simp [Simulation.moveL] + omega + +/-- Writing materialises the cell under the head, so it extends the span by at most that one +cell — and never by more, however long the machine runs. -/ +lemma Extent.write {t : Tape S} {lo p hi : ℤ} (s : S) (h : Extent t lo p hi) : + Extent (Simulation.write (t, s)) lo p (max hi (p + 1)) := by + obtain ⟨h1, h2, h3, h4⟩ := h + refine ⟨by omega, by omega, ?_, ?_⟩ + · have e : (Simulation.write ((t, s) : Tape S × S)).1.length + = t.1.length := by simp [Simulation.write] + omega + · cases hr : t.2 with + | nil => + have e : (Simulation.write ((t, s) : Tape S × S)).2.length = 1 := by + simp [Simulation.write, hr] + rw [hr] at h4 + simp only [List.length_nil] at h4 + omega + | cons x rest => + have e : (Simulation.write ((t, s) : Tape S × S)).2.length + = rest.length + 1 := by simp [Simulation.write, hr] + rw [hr] at h4 + simp only [List.length_cons] at h4 + omega + +/-! ### The shape `MultiTapeTM.Cfg` expects -/ + +/-- A finite stand-in for one work tape of `Turing.MultiTapeTM.Cfg`: a zipper together with the +head position. `workTapeFun` turns it into exactly the `ℤ → Option Symbol` that +`Cfg.workTapes i` is. -/ +abbrev WorkTape (Symbol : Type) := Tape (Option Symbol) × ℤ + +/-- The bi-infinite work tape denoted by a finite stand-in. -/ +def workTapeFun {Symbol : Type} (w : WorkTape Symbol) : ℤ → Option Symbol := + tapeFun none w.1 w.2 + +/-- **A real `MultiTapeTM.Cfg` built entirely from finite data.** + +Every field of `Cfg` except `workTapes` is already a finite value — an `Option State`, a +`Fin (n + 2)`, a `List Symbol`. Only the work tapes are functions, and `workTapeFun` supplies +them from zippers. So a configuration of a genuine multi-tape machine *is* encodable, and this +definition is the witness. -/ +def toCfg {k : ℕ} {Symbol State : Type} {input : List Symbol} + (state : Option State) (inputPos : Fin (input.length + 2)) + (ws : Fin k → WorkTape Symbol) (output : List Symbol) : + Cfg k Symbol State input where + state := state + inputPos := inputPos + workTapes i := workTapeFun (ws i) + workTapePos i := (ws i).2 + output := output + +@[simp] +lemma toCfg_workTapes {k : ℕ} {Symbol State : Type} {input : List Symbol} + (state : Option State) (inputPos : Fin (input.length + 2)) + (ws : Fin k → WorkTape Symbol) (output : List Symbol) (i : Fin k) : + (toCfg (State := State) (input := input) state inputPos ws output).workTapes i + = tapeFun none (ws i).1 (ws i).2 := rfl + +/-- Under the denotation, reading a work tape of the built configuration is reading the zipper — +`Cfg.workTapeSymbols` agrees with `Simulation.read`. -/ +lemma toCfg_workTapeSymbols {k : ℕ} {Symbol State : Type} {input : List Symbol} + (state : Option State) (inputPos : Fin (input.length + 2)) + (ws : Fin k → WorkTape Symbol) (output : List Symbol) (i : Fin k) : + (toCfg (State := State) (input := input) state inputPos ws output).workTapeSymbols i + = read none (ws i).1 := by + simp [Cfg.workTapeSymbols, toCfg, workTapeFun] + +end Simulation + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean index f6121307ea..7f2803d6da 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean @@ -237,6 +237,18 @@ def tail : Bounds (fun xs : List α => xs.tail) where have h2 := Data.two_le_size (DataEncode.encode x) simpa using by omega +/-- **Emptiness test.** Whether the input node has any children at all — one look at the tape, +no work space. -/ +def isEmpty : Bounds (fun l : List α => l.isEmpty) where + time n := n + 2 + space _ := 0 + outSize _ := 4 + time_mono := fun _ _ h => Nat.add_le_add_right h 2 + space_mono := monotone_const + outSize_mono := monotone_const + computes := sorry + out_le l := DataEncode.size_bool _ + /-- **Branching.** Evaluate the condition, then whichever branch it selects. `cond` is used rather than `if` so that no `Decidable` instance travels with the statement. -/ def ite {c : α → Bool} {f g : α → β} (hc : Bounds c) (hf : Bounds f) (hg : Bounds g) : From a2252c4cc017c943c17586071d946c56f61580d9 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 1 Sep 2026 11:57:04 +0200 Subject: [PATCH 3/8] refactor --- .../Machines/Turing/MultiTape/Complexity.lean | 50 +++++- .../Turing/MultiTape/Complexity/Bounds.lean | 16 +- .../Turing/MultiTape/Complexity/Data.lean | 4 - .../Turing/MultiTape/Complexity/Encoding.lean | 16 +- .../Complexity/Examples/ListIndex.lean | 19 +-- .../Complexity/Examples/ListMap.lean | 4 +- .../Complexity/Examples/ListUpdate.lean | 9 +- .../MultiTape/Complexity/Examples/Lookup.lean | 9 -- .../Complexity/Examples/MachineDesc.lean | 7 +- .../Complexity/Examples/NatArith.lean | 26 ++-- .../MultiTape/Complexity/Examples/NatMul.lean | 17 +- .../Complexity/Examples/SimConfig.lean | 18 +++ .../Complexity/Examples/SimSpace.lean | 147 ++++++++++++++++++ .../Complexity/Examples/SpaceBound.lean | 6 +- .../MultiTape/Complexity/Examples/Tape.lean | 12 +- .../Complexity/Examples/TapeStep.lean | 39 +++-- .../Complexity/Examples/TapeView.lean | 97 +++--------- .../Complexity/Examples/Universal.lean | 3 + .../Turing/MultiTape/Complexity/Fold.lean | 15 +- 19 files changed, 329 insertions(+), 185 deletions(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimSpace.lean diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean index 644e913c3b..ab9336fbcb 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean @@ -24,6 +24,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples. public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeView public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeStep public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SimConfig +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SimSpace public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.InputCursor public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SpaceBound public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Universal @@ -32,16 +33,29 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples. /-! # Complexity of multi-tape Turing machines (draft) -**STATUS: draft.** Not listed in `Cslib.lean`, because a number of statements are `sorry`-ed. They -fall into exactly two groups: +**STATUS: draft.** Not listed in `Cslib.lean`, because 18 statements are `sorry`-ed. They fall +into exactly two groups: -* **Machine constructions.** `Bounds.computes` for every primitive in `Primitives.lean`, - `Bounds.fold`, `ComputableUpTo.comp` and `foldl_computableUpTo`. No concrete multi-tape Turing - machine is built anywhere in this development, so every one of these is assumed. -* **`ComputableUpTo.absorb`**, routine `Nat.pow` arithmetic (proof sketch in its docstring). +* **Machine constructions** (17). The `Bounds.computes` field of every primitive in + `Primitives.lean`, of `Bounds.fold` and of `Bounds.while`, together with + `ComputableUpTo.comp` and `foldl_computableUpTo`. No concrete multi-tape Turing machine is built + anywhere in this development, so every one of these is assumed. +* **`ComputableUpTo.absorb`** (1), routine `Nat.pow` arithmetic (proof sketch in its docstring). Everything else is proved, and the split is checkable with `#print axioms`: the correctness of -each example's fold and all of the size bookkeeping come out free of `sorryAx`. +every example's fold, all of the size bookkeeping, and the whole simulation stack come out free of +`sorryAx`. + +## The main results + +* `foldl_computableUpTo` / `Bounds.fold` — the cost of a `List.foldl`, from the cost of its parts. +* `Bounds.while` — the same for unbounded iteration; note the time bound carries the trip count + and the space bound does not, because iterations reuse tapes. +* `Simulation.simulates` — a finite, *encodable* configuration reproduces a genuine + `Turing.MultiTapeTM` run, for every number of tapes, alphabet size and state count. `Cfg` itself + is not encodable: its `workTapes` field is a family of functions `ℤ → Option Symbol`. +* `Simulation.zipper_length_le_spaceUsed` — that simulation's storage is bounded by the simulated + machine's `spaceUsedByTape`, *not* by its running time. ## Layout @@ -54,7 +68,27 @@ each example's fold and all of the size bookkeeping come out free of `sorryAx`. | `Complexity/Primitives.lean` | the elementary building blocks (machines assumed) | | `Complexity/Fold.lean` | `foldl_computableUpTo` and `Bounds.fold` | | `Complexity/While.lean` | `Bounds.while`, unbounded iteration | -| `Complexity/Examples/` | `List.map`, indexing, `Nat` arithmetic, lookup, a universal machine | + +Worked examples of the fold theorem: + +| file | contents | +| --- | --- | +| `Examples/ListIndex.lean`, `ListMap.lean`, `ListUpdate.lean` | indexing, `map`, update | +| `Examples/NatArith.lean`, `NatMul.lean` | `succ`, `add`, `mul` on binary numerals | +| `Examples/Lookup.lean`, `LookupTable.lean` | association-list lookup and its faithfulness | + +The simulation stack, culminating in a result about `Turing.MultiTapeTM` itself: + +| file | contents | +| --- | --- | +| `Examples/Tape.lean`, `TapeView.lean` | tapes as zippers; `tapeFun`; `Extent` | +| `Examples/TapeStep.lean` | one work-tape action vs `step`'s tape update | +| `Examples/InputCursor.lean` | the input head, including `moveInputPos`'s clamping | +| `Examples/SpaceBound.lean` | discrete IVT; head span ≤ `spaceUsedByTape` | +| `Examples/MachineDesc.lean` | untyped machine descriptions, for any `k`/alphabet/states | +| `Examples/SimConfig.lean` | `SimCfg`, `Represents`, and the step commutation | +| `Examples/SimSpace.lean` | the simulation's storage, bounded by simulated space | +| `Examples/Universal.lean` | a universal machine over encoded transition tables | ## References diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean index 6bc8f4ff48..c2669fadf8 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean @@ -67,7 +67,21 @@ namespace Bounds /-- Transport a certificate along an equality of functions. Used to turn a certificate for the literal shape a combinator produces into one for the function actually of interest. -/ -def congr {f g : α → β} (b : Bounds f) (h : f = g) : Bounds g := h ▸ b +def congr {f g : α → β} (b : Bounds f) (h : f = g := by rfl) : Bounds g := h ▸ b + +/-- Transport leaves the time bound alone. Without this (and its siblings) the resource fields of +a transported certificate are stuck behind `Eq.rec` and cannot be read off, which would block +`Bounds.polyTimeLinSpace` for every certificate built via `congr`. -/ +@[simp] lemma congr_time {f g : α → β} (b : Bounds f) (h : f = g) : + (b.congr h).time = b.time := by cases h; rfl + +/-- Transport leaves the space bound alone. -/ +@[simp] lemma congr_space {f g : α → β} (b : Bounds f) (h : f = g) : + (b.congr h).space = b.space := by cases h; rfl + +/-- Transport leaves the output-size bound alone. -/ +@[simp] lemma congr_outSize {f g : α → β} (b : Bounds f) (h : f = g) : + (b.congr h).outSize = b.outSize := by cases h; rfl /-- Weaken all three bounds at once. Composition produces one specific closed form; this is how one restates it more readably. -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean index a329054099..464ec3e7c2 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean @@ -41,10 +41,6 @@ inductive Data where | l : List Data → Data deriving Repr -/-- The children of a node. -/ -def Data.asList : Data → List Data - | Data.l xs => xs - /-- The empty rose tree. -/ abbrev Data.empty : Data := Data.l [] diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean index 4f90fc1761..27d5fdd0e1 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean @@ -156,7 +156,7 @@ lemma natOfBits_cons (b : Bool) (bs : List Bool) : natOfBits (b :: bs) = Nat.bit b (natOfBits bs) := rfl /-- `Nat.bit` in arithmetic form. -/ -lemma Nat.bit_eq_two_mul_add (b : Bool) (n : ℕ) : +lemma natBit_eq_two_mul_add (b : Bool) (n : ℕ) : Nat.bit b n = 2 * n + cond b 1 0 := by cases b <;> simp [Nat.bit] @@ -169,7 +169,7 @@ lemma natOfBits_append_replicate_false (bs : List Bool) (k : ℕ) : simp only [List.nil_append] induction k with | zero => simp - | succ k ih => simp [List.replicate_succ, ih, Nat.bit_eq_two_mul_add] + | succ k ih => simp [List.replicate_succ, ih, natBit_eq_two_mul_add] | cons b bs ih => simp [ih] /-- A bit list of length `k` denotes a number below `2 ^ k`. -/ @@ -177,16 +177,16 @@ lemma natOfBits_lt (bs : List Bool) : natOfBits bs < 2 ^ bs.length := by induction bs with | nil => simp | cons b bs ih => - simp only [natOfBits_cons, Nat.bit_eq_two_mul_add, List.length_cons, pow_succ] + simp only [natOfBits_cons, natBit_eq_two_mul_add, List.length_cons, pow_succ] cases b <;> simp <;> omega /-- Multiplying adds at most the two bit lengths. -/ -lemma Nat.size_mul_le (a b : ℕ) : (a * b).size ≤ a.size + b.size := by +lemma natSize_mul_le (a b : ℕ) : (a * b).size ≤ a.size + b.size := by rw [Nat.size_le, pow_add] exact Nat.mul_lt_mul_of_lt_of_lt (Nat.lt_size_self a) (Nat.lt_size_self b) /-- A power of two has bit length one more than its exponent. -/ -lemma Nat.size_two_pow_le (j : ℕ) : (2 ^ j).size ≤ j + 1 := by +lemma natSize_two_pow_le (j : ℕ) : (2 ^ j).size ≤ j + 1 := by rw [Nat.size_le] exact Nat.pow_lt_pow_right (by omega) (by omega) @@ -271,6 +271,12 @@ lemma DataEncode.size_cons {α : Type} [DataEncode α] (x : α) (xs : List α) : simp only [List.map_cons, List.sum_cons] omega +@[simp] +lemma DataEncode.size_nil {α : Type} [DataEncode α] : + (DataEncode.encode ([] : List α)).size = 2 := by + change (Data.l []).size = 2 + simp [Data.size] + @[simp] lemma DataEncode.size_none {α : Type} [DataEncode α] : (DataEncode.encode (none : Option α)).size = 2 := by diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean index 9d9a8571a0..f0decd1d01 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean @@ -105,18 +105,6 @@ lemma foldFun_snd (p : ℕ × List α) : /-! ### Size bookkeeping -/ -private lemma mem_of_mem_take {l : List α} {j : ℕ} {x : α} (h : x ∈ l.take j) : x ∈ l := by - induction l generalizing j with - | nil => simp at h - | cons y ys ih => - cases j with - | zero => simp at h - | succ k => - rw [List.take_succ_cons] at h - rcases List.mem_cons.mp h with h | h - · simp [h] - · exact List.mem_cons_of_mem _ (ih h) - /-- The counter never exceeds its initial value. -/ lemma foldl_fst_le (l : List α) (m : ℕ) (r : Option α) : (l.foldl stepFn (m, r)).1 ≤ m := by @@ -171,7 +159,7 @@ lemma accSize [DataEncode α] (p : ℕ × List α) (j : ℕ) : · rw [h, DataEncode.size_none] omega · rw [hx2, DataEncode.size_some] - have := DataEncode.size_mem_le (mem_of_mem_take hx) + have := DataEncode.size_mem_le (List.mem_of_mem_take hx) omega -- split the encoded pair (uses eta for structures) have hsplit : (DataEncode.encode ((l.take j).foldl stepFn (i + 1, none))).size @@ -184,9 +172,8 @@ lemma accSize [DataEncode α] (p : ℕ × List α) (j : ℕ) : /-- The output of the fold is an accumulator, so it obeys the same bound: `S_f n = n + 8`. -/ lemma foldOutSize [DataEncode α] (p : ℕ × List α) : (DataEncode.encode (foldFun listFn initFn stepFn p)).size - ≤ (DataEncode.encode p).size + 8 := by - rw [← foldAcc_length listFn initFn stepFn p] - exact accSize p _ + ≤ (DataEncode.encode p).size + 8 := + foldFun_size_le (fun n => n + 8) accSize p /-! ### The complexity statement -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean index d7247e5f45..76b58b61e5 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean @@ -102,9 +102,7 @@ theorem map_polyTimeLinSpace (f : α → β) (c : ℕ) funext (foldFun_map f) rw [h_eq] at h_fold refine h_fold.absorb (c + 8) 2 (2 * c + 6) (fun n => ?_) (fun n => ?_) - · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring - rw [hexp] - nlinarith + · nlinarith [sq_nonneg n] · nlinarith /-- **`List.map` in the `Bounds` algebra.** diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean index def611f8c6..f175b4944c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean @@ -217,9 +217,8 @@ lemma accSize [DataEncode α] (p : ℕ × α × List α) (j : ℕ) : /-- The output of the fold is an accumulator, so it obeys the same bound: `S_f n = 2 * n + 6`. -/ lemma foldOutSize [DataEncode α] (p : ℕ × α × List α) : (DataEncode.encode (foldFun updateList updateInit updateStep p)).size - ≤ 2 * (DataEncode.encode p).size + 6 := by - rw [← foldAcc_length updateList updateInit updateStep p] - exact accSize p _ + ≤ 2 * (DataEncode.encode p).size + 6 := + foldFun_size_le (fun n => 2 * n + 6) accSize p /-! ### The complexity statement -/ @@ -266,9 +265,7 @@ def listBounds [DataEncode α] : Bounds (updateList (α := α)) := /-- Projecting the output list out of the accumulator is the same two projections. -/ def outBounds [DataEncode α] : Bounds (updateOut (α := α)) := - Bounds.congr - (Bounds.comp (Bounds.snd : Bounds (Prod.snd : α × List α → List α)) - (Bounds.snd : Bounds (Prod.snd : ℕ × α × List α → α × List α))) rfl + listBounds /-- **List update in the `Bounds` algebra.** diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean index 8cd48c8ada..b15940e468 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean @@ -101,15 +101,6 @@ lemma lookupAccSize [Fintype K] [Fintype V] (p : Table K V × K) (j : ℕ) : Finset.le_sup (f := fun a : K × Option V => (DataEncode.encode a).size) (Finset.mem_univ _) omit [BEq K] in -lemma lookupListSize (p : Table K V × K) : - (DataEncode.encode (lookupList p)).size ≤ (DataEncode.encode p).size := by - obtain ⟨tbl, k⟩ := p - have h : (DataEncode.encode ((tbl, k) : Table K V × K)).size - = (DataEncode.encode tbl).size + (DataEncode.encode k).size + 2 := - DataEncode.size_pair _ _ - change (DataEncode.encode tbl).size ≤ _ - omega - /-! ### The certificate -/ /-- **A resource certificate for lookup**, from `Bounds.fold`. The step is a function between diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean index b0bbc8e55c..7af7096afa 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean @@ -20,7 +20,7 @@ This file therefore replaces every one of those types by `ℕ`. A state is its i is `Option ℕ` (with `none` the blank), and the work-head tuple `Fin k → Option Symbol` becomes a plain `List`. The resulting types `UKey` and `UOut` are built solely from `ℕ`, `Option`, `List`, `Prod` and `SignType`, so they inherit `DataEncode` from `Encoding` with no new instance, and — -this is the point of being untyped — a *single* value of type `UTable` can describe a machine for +this is the point of being untyped — one `UntypedTable` value can describe a machine for any `k`, any alphabet size and any state count. One universal machine can interpret them all. The description itself, `desc`, is the transition function tabulated over its (finite) domain: @@ -56,7 +56,7 @@ symbol to output and the successor state (`none` to halt). -/ abbrev UOut := SignType × List UAction × USym × Option ℕ /-- An untyped machine description: the transition function as an association list. -/ -abbrev UTable := Lookup.Table UKey UOut +abbrev UntypedTable := Lookup.Table UKey UOut /-! ### Erasing the types -/ @@ -74,7 +74,8 @@ def outOf {k sym state : ℕ} (o : TransitionOut k (Fin sym) (Fin state)) : UOut /-- **The description of a machine**: its transition function tabulated over the whole (finite) domain, keyed by `keyOf`. -/ -noncomputable def desc {k sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) : UTable := +noncomputable def desc {k sym state : ℕ} + (tm : MultiTapeTM k (Fin sym) (Fin state)) : UntypedTable := Finset.univ.toList.map fun x : Fin state × Option (Fin sym) × (Fin k → Option (Fin sym)) => (keyOf x.1 x.2.1 x.2.2, outOf (tm.tr x.1 x.2.1 x.2.2)) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean index eaef82faeb..d01ca150ae 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean @@ -74,10 +74,10 @@ lemma natOfBits_incSpec (c : Bool) (bs : List Bool) : natOfBits ((incSpec c bs).2 ++ cond (incSpec c bs).1 [true] []) = natOfBits bs + cond c 1 0 := by induction bs generalizing c with - | nil => cases c <;> simp [incSpec, Nat.bit_eq_two_mul_add] + | nil => cases c <;> simp [incSpec, natBit_eq_two_mul_add] | cons b bs ih => have h := ih (c && b) - simp only [incSpec, List.cons_append, natOfBits_cons, Nat.bit_eq_two_mul_add] + simp only [incSpec, List.cons_append, natOfBits_cons, natBit_eq_two_mul_add] rw [h] cases c <;> cases b all_goals simp @@ -124,9 +124,8 @@ lemma succAccSize (n j : ℕ) : lemma succFoldOutSize (n : ℕ) : (DataEncode.encode (foldFun succList succInit succStep n)).size - ≤ 4 * (DataEncode.encode n).size + 8 := by - rw [← foldAcc_length succList succInit succStep n] - exact succAccSize n _ + ≤ 4 * (DataEncode.encode n).size + 8 := + foldFun_size_le (fun n => 4 * n + 8) succAccSize n /-- **`Nat.succ` runs in polynomial time and linear space.** -/ theorem succ_polyTimeLinSpace @@ -145,9 +144,7 @@ theorem succ_polyTimeLinSpace funext flushCarry_foldFun rw [h_eq] at h_comp refine h_comp.absorb 6 2 34 (fun n => ?_) (fun n => ?_) - · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring - rw [hexp] - nlinarith + · nlinarith [sq_nonneg n] · omega end NatSucc @@ -218,12 +215,12 @@ lemma natOfBits_addSpec (c : Bool) (ps : List (Bool × Bool)) : natOfBits ((addSpec c ps).2 ++ cond (addSpec c ps).1 [true] []) = natOfBits (ps.map Prod.fst) + natOfBits (ps.map Prod.snd) + cond c 1 0 := by induction ps generalizing c with - | nil => cases c <;> simp [addSpec, Nat.bit_eq_two_mul_add] + | nil => cases c <;> simp [addSpec, natBit_eq_two_mul_add] | cons xy ps ih => obtain ⟨x, y⟩ := xy have h := ih (carryOut c x y) simp only [addSpec, List.cons_append, List.map_cons, natOfBits_cons, - Nat.bit_eq_two_mul_add] + natBit_eq_two_mul_add] rw [h] cases c <;> cases x <;> cases y <;> simp [sumBit, carryOut] <;> omega @@ -300,9 +297,8 @@ lemma addAccSize (p : ℕ × ℕ) (j : ℕ) : lemma addFoldOutSize (p : ℕ × ℕ) : (DataEncode.encode (foldFun addList addInit addStep p)).size - ≤ 4 * (DataEncode.encode p).size + 8 := by - rw [← foldAcc_length addList addInit addStep p] - exact addAccSize p _ + ≤ 4 * (DataEncode.encode p).size + 8 := + foldFun_size_le (fun n => 4 * n + 8) addAccSize p /-- **`Nat.add` runs in polynomial time and linear space.** -/ theorem add_polyTimeLinSpace @@ -321,9 +317,7 @@ theorem add_polyTimeLinSpace funext flushCarry_foldFun rw [h_eq] at h_comp refine h_comp.absorb 40 2 38 (fun n => ?_) (fun n => ?_) - · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring - rw [hexp] - nlinarith + · nlinarith [sq_nonneg n] · omega end NatAdd diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean index cf32defc2b..0a374150d1 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean @@ -57,7 +57,7 @@ lemma foldl_mulStep (bs : List Bool) (acc sh : ℕ) : change (bs.foldl mulStep (acc + cond b sh 0, sh + sh)) = _ rw [ih] cases b <;> - simp only [natOfBits_cons, Nat.bit_eq_two_mul_add, List.length_cons, pow_succ, + simp only [natOfBits_cons, natBit_eq_two_mul_add, List.length_cons, pow_succ, Bool.cond_true, Bool.cond_false, Prod.mk.injEq] <;> constructor <;> ring @@ -98,10 +98,10 @@ lemma mulAccSize (p : ℕ × ℕ) (j : ℕ) : rw [List.length_take, Nat.size_eq_bits_len] omega have h1 : (natOfBits (b.bits.take j) * a).size ≤ b.size + a.size := - le_trans (Nat.size_mul_le _ _) (Nat.add_le_add_right (size_natOfBits_take b j) _) + le_trans (natSize_mul_le _ _) (Nat.add_le_add_right (size_natOfBits_take b j) _) have h2 : (a * 2 ^ (b.bits.take j).length).size ≤ a.size + b.size + 1 := by - have := Nat.size_mul_le a (2 ^ (b.bits.take j).length) - have := Nat.size_two_pow_le (b.bits.take j).length + have := natSize_mul_le a (2 ^ (b.bits.take j).length) + have := natSize_two_pow_le (b.bits.take j).length omega rw [foldAcc_mul, DataEncode.size_pair, DataEncode.size_pair, DataEncode.size_nat, DataEncode.size_nat, DataEncode.size_nat, DataEncode.size_nat] @@ -119,9 +119,8 @@ lemma mulListSize (p : ℕ × ℕ) : lemma mulFoldOutSize (p : ℕ × ℕ) : (DataEncode.encode (foldFun mulList mulInit mulStep p)).size - ≤ 2 * (DataEncode.encode p).size := by - rw [← foldAcc_length mulList mulInit mulStep p] - exact mulAccSize p _ + ≤ 2 * (DataEncode.encode p).size := + foldFun_size_le (fun n => 2 * n) mulAccSize p /-- **`Nat.mul` runs in polynomial time and linear space.** -/ theorem mul_polyTimeLinSpace @@ -140,9 +139,7 @@ theorem mul_polyTimeLinSpace funext foldFun_mul rw [h_eq] at h_comp refine h_comp.absorb 1 2 12 (fun n => ?_) (fun n => ?_) - · have hexp : (n + n + 2) ^ 2 = 4 * n * n + 8 * n + 4 := by ring - rw [hexp] - nlinarith + · nlinarith [sq_nonneg n] · omega end NatMul diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean index 857c9a3926..9bdf84d3c0 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean @@ -227,6 +227,24 @@ lemma Represents.step {sym state : ℕ} {inp : List (Fin sym)} simp only [] rw [hout] +/-- How `cfgStep` acts on a single work zipper, given the transition it uses. -/ +lemma workZipper_cfgStep {sym state : ℕ} (tm : MultiTapeTM k (Fin sym) (Fin state)) + (sc : SimCfg sym state) (q : Fin state) (hq : sc.1 = some q) + (o : TransitionOut k (Fin sym) (Fin state)) + (ho : tm.tr q (cursorRead none sc.2.1) + (fun j : Fin k => read none (workZipper sc j.val)) = o) (i : Fin k) : + workZipper (cfgStep tm sc) i.val + = applyAction none (o.workActions i) (workZipper sc i.val) := by + have hsim : cfgStep tm sc = + (o.q', moveCursor none o.inputMove sc.2.1, + List.ofFn (fun j : Fin k => applyAction none (o.workActions j) (workZipper sc j.val)), + sc.2.2.2 ++ o.outS.toList) := by + simp only [cfgStep, hq, ho] + rw [hsim] + unfold workZipper + rw [List.getElem?_ofFn, dite_eq_left i.isLt] + simp + /-! ### Assembly: a finite computation reproduces the whole run -/ /-- The finite stand-in for the initial configuration: the start state, the cursor just past the diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimSpace.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimSpace.lean new file mode 100644 index 0000000000..53fbf4a74a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimSpace.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SimConfig +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SpaceBound + +/-! +# The simulation runs in the simulated machine's space + +`SimConfig` shows the finite stand-in reproduces a machine's run. This file bounds its *size*, and +bounds it by the simulated machine's **space** rather than by its running time — the distinction +that makes a simulation worth having, since a machine may run for exponentially many steps in +polynomial space. + +The argument has two halves, both already proved elsewhere: + +* `Extent` says a zipper stores exactly the cells spanned by the positions its head has covered, + so it grows only on ground the head has not been on before; +* `span_le_spaceUsedByTape` says that span is bounded by the number of distinct cells visited, + which is exactly `MultiTapeTM.spaceUsedByTape`. + +`ExtentOK` is what carries the first half along a run: it pins each zipper's extent between two +positions the head has actually occupied (to within one cell). Because `Extent.of_applyAction` moves +an endpoint only *to the head's own position*, that invariant survives each step, and no +`min`/`max` over the whole history is needed. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +namespace Simulation + +open RoseTreeMachine + +variable {k sym state : ℕ} + +/-- The position of work head `i` at time `t` of the canonical run. -/ +def headPos (tm : MultiTapeTM k (Fin sym) (Fin state)) (inp : List (Fin sym)) + (i : Fin k) (t : ℕ) : ℤ := + (tm.runFrom (tm.initCfg inp) t).workTapePos i + +/-- The finite stand-in after `t` steps. -/ +def simRun (tm : MultiTapeTM k (Fin sym) (Fin state)) (inp : List (Fin sym)) (t : ℕ) : + SimCfg sym state := + (cfgStep tm)^[t] (initSimCfg tm inp) + +/-- **The extent invariant along a run**: the zipper for tape `i` has an extent whose endpoints +each lie within one cell of a position the head has actually occupied. -/ +def ExtentOK (tm : MultiTapeTM k (Fin sym) (Fin state)) (inp : List (Fin sym)) + (i : Fin k) (t : ℕ) : Prop := + ∃ lo hi, Extent (workZipper (simRun tm inp t) i.val) lo (headPos tm inp i t) hi + ∧ (∃ a ≤ t, headPos tm inp i a - 1 ≤ lo) + ∧ (∃ b ≤ t, hi ≤ headPos tm inp i b + 1) + +lemma extentOK_zero (tm : MultiTapeTM k (Fin sym) (Fin state)) (inp : List (Fin sym)) + (i : Fin k) : ExtentOK tm inp i 0 := by + have hz : workZipper (simRun tm inp 0) i.val = (([], []) : Tape (Option (Fin sym))) := by + unfold simRun workZipper initSimCfg + simp [i.isLt] + have hp : headPos tm inp i 0 = 0 := by simp [headPos] + refine ⟨0, 0, ?_, ⟨0, le_refl _, ?_⟩, ⟨0, le_refl _, ?_⟩⟩ + · rw [hz, hp]; exact Extent.init + · rw [hp]; omega + · rw [hp]; omega + +lemma extentOK_succ (tm : MultiTapeTM k (Fin sym) (Fin state)) (inp : List (Fin sym)) + (i : Fin k) (t : ℕ) (h : ExtentOK tm inp i t) : ExtentOK tm inp i (t + 1) := by + obtain ⟨lo, hi, hext, ⟨a, ha, hla⟩, ⟨b, hb, hhb⟩⟩ := h + have hrep : Represents (simRun tm inp t) (tm.runFrom (tm.initCfg inp) t) := + simulates tm inp t + have hrun : simRun tm inp (t + 1) = cfgStep tm (simRun tm inp t) := by + unfold simRun + rw [Function.iterate_succ_apply'] + cases hq : (simRun tm inp t).1 with + | none => + -- the machine has halted, so nothing changes + have hcfg : (tm.runFrom (tm.initCfg inp) t).state = none := by rw [← hrep.1, hq] + have hstep : tm.runFrom (tm.initCfg inp) (t + 1) = tm.runFrom (tm.initCfg inp) t := by + rw [MultiTapeTM.runFrom_succ_eq_step', MultiTapeTM.step_of_halt hcfg] + have hz : workZipper (simRun tm inp (t + 1)) i.val = workZipper (simRun tm inp t) i.val := by + rw [hrun] + have : cfgStep tm (simRun tm inp t) = simRun tm inp t := by simp [cfgStep, hq] + rw [this] + have hp : headPos tm inp i (t + 1) = headPos tm inp i t := by + unfold headPos; rw [hstep] + exact ⟨lo, hi, by rw [hz, hp]; exact hext, + ⟨a, by omega, hla⟩, ⟨b, by omega, hhb⟩⟩ + | some q => + have hcfg : (tm.runFrom (tm.initCfg inp) t).state = some q := by rw [← hrep.1, hq] + set cfg := tm.runFrom (tm.initCfg inp) t with hcfgdef + set o := tm.tr q cfg.inputSymbol cfg.workTapeSymbols with hodef + have ho : tm.tr q (cursorRead none (simRun tm inp t).2.1) + (fun j : Fin k => read none (workZipper (simRun tm inp t) j.val)) = o := + Represents.tr_eq hrep tm q + have hz := workZipper_cfgStep tm (simRun tm inp t) q hq o ho i + rw [← hrun] at hz + have hp : headPos tm inp i (t + 1) = headPos tm inp i t + (o.workActions i).2 := by + unfold headPos + rw [MultiTapeTM.runFrom_succ_eq_step', step_workTapePos tm cfg q hcfg i] + obtain ⟨lo', hi', hext', _, _, _, _, hlo', hhi'⟩ := + Extent.of_applyAction (blank := (none : Option (Fin sym))) (o.workActions i) hext + refine ⟨lo', hi', ?_, ?_, ?_⟩ + · rw [hz, hp] + exact hext' + · rcases hlo' with hl | hl + · exact ⟨a, by omega, by omega⟩ + · exact ⟨t + 1, le_refl _, by rw [hp]; omega⟩ + · rcases hhi' with hh | hh + · exact ⟨b, by omega, by omega⟩ + · exact ⟨t, by omega, by omega⟩ + +lemma extentOK (tm : MultiTapeTM k (Fin sym) (Fin state)) (inp : List (Fin sym)) + (i : Fin k) (t : ℕ) : ExtentOK tm inp i t := by + induction t with + | zero => exact extentOK_zero tm inp i + | succ t ih => exact extentOK_succ tm inp i t ih + +/-- **The simulation's tapes are bounded by the simulated machine's space.** + +The number of cells the stand-in stores for work tape `i` after `t` steps is at most the number of +cells the real machine's head has visited, plus one. In particular it does *not* grow with the +running time: a machine that runs for exponentially many steps in a bounded region is simulated in +a bounded amount of storage. -/ +theorem zipper_length_le_spaceUsed (tm : MultiTapeTM k (Fin sym) (Fin state)) + (inp : List (Fin sym)) (i : Fin k) (t : ℕ) : + (workZipper (simRun tm inp t) i.val).1.length + + (workZipper (simRun tm inp t) i.val).2.length + ≤ tm.spaceUsedByTape (tm.initCfg inp) t i + 1 := by + obtain ⟨lo, hi, hext, ⟨a, ha, hla⟩, ⟨b, hb, hhb⟩⟩ := extentOK tm inp i t + have hlen := Extent.length_eq hext + have hspan := span_le_spaceUsedByTape tm (tm.initCfg inp) t i ha hb + unfold headPos at hla hhb + omega + +end Simulation + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean index 9b051b9947..03bc377d6e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean @@ -82,7 +82,8 @@ lemma exists_eq_between {f : ℕ → ℤ} (hstep : ∀ j, |f (j + 1) - f j| ≤ /-- **The span between any two visited positions is bounded by the number of positions visited.** This is the abstract form of "a zipper is no bigger than the space used". -/ -lemma card_image_ge {f : ℕ → ℤ} (hstep : ∀ j, |f (j + 1) - f j| ≤ 1) (n : ℕ) {a b : ℕ} +lemma natAbs_sub_add_one_le_card_image {f : ℕ → ℤ} + (hstep : ∀ j, |f (j + 1) - f j| ≤ 1) (n : ℕ) {a b : ℕ} (ha : a ≤ n) (hb : b ≤ n) : (f b - f a).natAbs + 1 ≤ ((Finset.range (n + 1)).image f).card := by have hsub : Finset.Icc (min (f a) (f b)) (max (f a) (f b)) @@ -117,7 +118,8 @@ lemma span_le_spaceUsedByTape {k : ℕ} {Symbol State : Type*} rw [MultiTapeTM.runFrom_succ_eq_step'] exact MultiTapeTM.workTapePos_step_le _ i unfold MultiTapeTM.spaceUsedByTape MultiTapeTM.visitedByTapeHead - exact card_image_ge (f := fun j => (tm.runFrom cfg j).workTapePos i) hstep t ha hb + exact natAbs_sub_add_one_le_card_image + (f := fun j => (tm.runFrom cfg j).workTapePos i) hstep t ha hb end Simulation diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean index 84f86ef68a..b047a1dd6e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean @@ -30,13 +30,13 @@ get their certificates by composing `Bounds.fst`, `Bounds.snd`, `Bounds.cons`, ` is introduced.** One step of a simulated single-tape machine costs no more than the primitives it is built from, and the bound is computed rather than asserted. -## What is still missing for a universal machine +## Where this leads -`simStep` takes its transition function `tr` as a *fixed* function on finite types, so -`Bounds.ofFintype` applies. A genuinely universal machine reads the transition table off its input -instead, which means looking a key up in an encoded association list — that is a fold with an -`Option` accumulator, structurally the same argument as `ListIndex`. That, plus iterating `simStep` -under a step counter, is what remains. +`simStep` takes its transition function as a *fixed* function on finite types, so +`Bounds.ofFintype` covers it. A genuinely universal machine reads its transition table off the +input instead; that search is `Examples/Lookup.lean`, and the machine built on it is +`Examples/Universal.lean`. What remains missing is only the machines themselves — see the status +note in `Complexity.lean`. -/ @[expose] public section diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean index a7064684dd..d32ccb877d 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean @@ -118,10 +118,11 @@ The exact new extent depends on the action — a no-op widens nothing, a write c the head, a move covers the cell it steps onto — so the statement is existential in `lo'` and `hi'` with the widening bounded. That bound is what keeps a simulation's space proportional to the simulated machine's space rather than to its running time. -/ -lemma Extent.applyAction (blank : S) (a : Option S × SignType) {t : Tape S} {lo p hi : ℤ} +lemma Extent.of_applyAction (blank : S) (a : Option S × SignType) {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : - ∃ lo' hi', Extent (Simulation.applyAction blank a t) lo' (p + (a.2 : ℤ)) hi' - ∧ min lo (p - 1) ≤ lo' ∧ lo' ≤ lo ∧ hi ≤ hi' ∧ hi' ≤ max hi (p + 1) := by + ∃ lo' hi', Extent (applyAction blank a t) lo' (p + (a.2 : ℤ)) hi' + ∧ min lo (p - 1) ≤ lo' ∧ lo' ≤ lo ∧ hi ≤ hi' ∧ hi' ≤ max hi (p + 1) + ∧ (lo' = lo ∨ lo' = p + (a.2 : ℤ)) ∧ (hi' = hi ∨ hi' = p + 1) := by obtain ⟨h1, h2, _, _⟩ := id h obtain ⟨w, m⟩ := a have hz : p + ((SignType.zero : SignType) : ℤ) = p := by rw [signCast_zero]; ring @@ -135,39 +136,37 @@ lemma Extent.applyAction (blank : S) (a : Option S × SignType) {t : Tape S} {lo rw [hz, applyAction_none_zero] exact h | neg => - refine ⟨min lo (p - 1), hi, ?_, by omega, by omega, by omega, by omega⟩ + refine ⟨min lo (p - 1), hi, ?_, by omega, by omega, by omega, by omega, + by rw [signCast_neg]; omega, Or.inl rfl⟩ rw [hn, applyAction_none_neg] - exact Extent.moveL blank h + exact Extent.of_moveL blank h | pos => - refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ + refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega, + Or.inl rfl, by omega⟩ rw [hp, applyAction_none_pos] - exact Extent.moveR blank h + exact Extent.of_moveR blank h | some s => - have hw : Extent (Simulation.write (t, s)) lo p (max hi (p + 1)) := Extent.write s h + have hw : Extent (write (t, s)) lo p (max hi (p + 1)) := Extent.of_write s h cases m with | zero => - refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ + refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega, + Or.inl rfl, by omega⟩ rw [hz, applyAction_some_zero] exact hw | neg => - refine ⟨min lo (p - 1), max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ + refine ⟨min lo (p - 1), max hi (p + 1), ?_, by omega, by omega, by omega, by omega, + by rw [signCast_neg]; omega, by omega⟩ rw [hn, applyAction_some_neg] - exact Extent.moveL blank hw + exact Extent.of_moveL blank hw | pos => - refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega⟩ - have hm := Extent.moveR blank hw + refine ⟨lo, max hi (p + 1), ?_, by omega, by omega, by omega, by omega, + Or.inl rfl, by omega⟩ + have hm := Extent.of_moveR blank hw have hmax : max (max hi (p + 1)) (p + 1) = max hi (p + 1) := by omega rw [hmax] at hm rw [hp, applyAction_some_pos] exact hm -/-- The stored span grows by at most two cells per action. -/ -lemma Extent.applyAction_span {lo p hi lo' hi' : ℤ} - (h1 : min lo (p - 1) ≤ lo') (h2 : lo' ≤ lo) (h3 : hi ≤ hi') (h4 : hi' ≤ max hi (p + 1)) - (hlo : lo ≤ p) (hhi : p ≤ hi) : - (hi' - lo').toNat ≤ (hi - lo).toNat + 2 := by - omega - end Simulation end MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean index 5906820730..3580230644 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean @@ -28,18 +28,12 @@ configuration reachable from a finite starting tape is denoted by some zipper. ## What this does *not* do -It does not build a universal `MultiTapeTM`. Two things are still missing, and they are of very -different kinds: - -1. **Configuration-level simulation.** Lifting these lemmas from one tape to a whole - `MultiTapeTM.Cfg` — `k` work tapes (a `Fin k`-indexed family, so its finite stand-in is a - vector), the input head's `Fin (n + 2)` position, and the output list — and proving the finite - step commutes with `MultiTapeTM.step`. This is ordinary work: provable, just long. -2. **Existence of the machine.** A statement of the form "there is a `MultiTapeTM` that simulates - every `MultiTapeTM`" cannot be proved from anything in this development, because *no* concrete - multi-tape machine is constructed anywhere in it. It reduces to the same assumed primitives as - every other example — see the status note in `Complexity.lean`. Building one is the real - remaining task, and nothing here shortens it. +It does not build a universal `MultiTapeTM`. The configuration-level simulation this file supports +is carried out in `Examples/SimConfig.lean` (`Represents`, `simulates`) and costed in +`Examples/SimSpace.lean`. What is still missing is only the existence of the machines: no concrete +multi-tape machine is constructed anywhere in this development, so a statement of the form "there +is a `MultiTapeTM` that simulates every `MultiTapeTM`" reduces to the assumed primitives listed in +`Complexity.lean` and is not shortened by anything here. -/ @[expose] public section @@ -141,109 +135,66 @@ lemma Extent.length_eq {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : omega /-- Moving right extends the span only if the head was already at its right edge. -/ -lemma Extent.moveR (blank : S) {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : - Extent (Simulation.moveR blank t) lo (p + 1) (max hi (p + 1)) := by +lemma Extent.of_moveR (blank : S) {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : + Extent (moveR blank t) lo (p + 1) (max hi (p + 1)) := by obtain ⟨h1, h2, h3, h4⟩ := h refine ⟨by omega, by omega, ?_, ?_⟩ - · have e : (Simulation.moveR blank t).1.length = t.1.length + 1 := by simp [Simulation.moveR] + · have e : (moveR blank t).1.length = t.1.length + 1 := by simp [moveR] omega · cases hr : t.2 with | nil => - have e : (Simulation.moveR blank t).2.length = 0 := by simp [Simulation.moveR, hr] + have e : (moveR blank t).2.length = 0 := by simp [moveR, hr] rw [hr] at h4 simp only [List.length_nil] at h4 omega | cons x rest => - have e : (Simulation.moveR blank t).2.length = rest.length := by simp [Simulation.moveR, hr] + have e : (moveR blank t).2.length = rest.length := by simp [moveR, hr] rw [hr] at h4 simp only [List.length_cons] at h4 omega /-- Moving left extends the span only if the head was already at its left edge. -/ -lemma Extent.moveL (blank : S) {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : - Extent (Simulation.moveL blank t) (min lo (p - 1)) (p - 1) hi := by +lemma Extent.of_moveL (blank : S) {t : Tape S} {lo p hi : ℤ} (h : Extent t lo p hi) : + Extent (moveL blank t) (min lo (p - 1)) (p - 1) hi := by obtain ⟨h1, h2, h3, h4⟩ := h refine ⟨by omega, by omega, ?_, ?_⟩ · cases hl : t.1 with | nil => - have e : (Simulation.moveL blank t).1.length = 0 := by simp [Simulation.moveL, hl] + have e : (moveL blank t).1.length = 0 := by simp [moveL, hl] rw [hl] at h3 simp only [List.length_nil] at h3 omega | cons x l' => - have e : (Simulation.moveL blank t).1.length = l'.length := by simp [Simulation.moveL, hl] + have e : (moveL blank t).1.length = l'.length := by simp [moveL, hl] rw [hl] at h3 simp only [List.length_cons] at h3 omega - · have e : (Simulation.moveL blank t).2.length = t.2.length + 1 := by simp [Simulation.moveL] + · have e : (moveL blank t).2.length = t.2.length + 1 := by simp [moveL] omega /-- Writing materialises the cell under the head, so it extends the span by at most that one cell — and never by more, however long the machine runs. -/ -lemma Extent.write {t : Tape S} {lo p hi : ℤ} (s : S) (h : Extent t lo p hi) : - Extent (Simulation.write (t, s)) lo p (max hi (p + 1)) := by +lemma Extent.of_write {t : Tape S} {lo p hi : ℤ} (s : S) (h : Extent t lo p hi) : + Extent (write (t, s)) lo p (max hi (p + 1)) := by obtain ⟨h1, h2, h3, h4⟩ := h refine ⟨by omega, by omega, ?_, ?_⟩ - · have e : (Simulation.write ((t, s) : Tape S × S)).1.length - = t.1.length := by simp [Simulation.write] + · have e : (write ((t, s) : Tape S × S)).1.length + = t.1.length := by simp [write] omega · cases hr : t.2 with | nil => - have e : (Simulation.write ((t, s) : Tape S × S)).2.length = 1 := by - simp [Simulation.write, hr] + have e : (write ((t, s) : Tape S × S)).2.length = 1 := by + simp [write, hr] rw [hr] at h4 simp only [List.length_nil] at h4 omega | cons x rest => - have e : (Simulation.write ((t, s) : Tape S × S)).2.length - = rest.length + 1 := by simp [Simulation.write, hr] + have e : (write ((t, s) : Tape S × S)).2.length + = rest.length + 1 := by simp [write, hr] rw [hr] at h4 simp only [List.length_cons] at h4 omega -/-! ### The shape `MultiTapeTM.Cfg` expects -/ - -/-- A finite stand-in for one work tape of `Turing.MultiTapeTM.Cfg`: a zipper together with the -head position. `workTapeFun` turns it into exactly the `ℤ → Option Symbol` that -`Cfg.workTapes i` is. -/ -abbrev WorkTape (Symbol : Type) := Tape (Option Symbol) × ℤ - -/-- The bi-infinite work tape denoted by a finite stand-in. -/ -def workTapeFun {Symbol : Type} (w : WorkTape Symbol) : ℤ → Option Symbol := - tapeFun none w.1 w.2 - -/-- **A real `MultiTapeTM.Cfg` built entirely from finite data.** - -Every field of `Cfg` except `workTapes` is already a finite value — an `Option State`, a -`Fin (n + 2)`, a `List Symbol`. Only the work tapes are functions, and `workTapeFun` supplies -them from zippers. So a configuration of a genuine multi-tape machine *is* encodable, and this -definition is the witness. -/ -def toCfg {k : ℕ} {Symbol State : Type} {input : List Symbol} - (state : Option State) (inputPos : Fin (input.length + 2)) - (ws : Fin k → WorkTape Symbol) (output : List Symbol) : - Cfg k Symbol State input where - state := state - inputPos := inputPos - workTapes i := workTapeFun (ws i) - workTapePos i := (ws i).2 - output := output - -@[simp] -lemma toCfg_workTapes {k : ℕ} {Symbol State : Type} {input : List Symbol} - (state : Option State) (inputPos : Fin (input.length + 2)) - (ws : Fin k → WorkTape Symbol) (output : List Symbol) (i : Fin k) : - (toCfg (State := State) (input := input) state inputPos ws output).workTapes i - = tapeFun none (ws i).1 (ws i).2 := rfl - -/-- Under the denotation, reading a work tape of the built configuration is reading the zipper — -`Cfg.workTapeSymbols` agrees with `Simulation.read`. -/ -lemma toCfg_workTapeSymbols {k : ℕ} {Symbol State : Type} {input : List Symbol} - (state : Option State) (inputPos : Fin (input.length + 2)) - (ws : Fin k → WorkTape Symbol) (output : List Symbol) (i : Fin k) : - (toCfg (State := State) (input := input) state inputPos ws output).workTapeSymbols i - = read none (ws i).1 := by - simp [Cfg.workTapeSymbols, toCfg, workTapeFun] - end Simulation end MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean index cbd9fb53d5..56b3d76185 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean @@ -311,6 +311,7 @@ lemma countStep_size_le [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) ( unfold countGrowth omega +/-- A certificate for the counting step: tick the counter and take one universal step. -/ def countStepBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) : Bounds (countStep blank dflt) := (Bounds.pair @@ -319,10 +320,12 @@ def countStepBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) : (Bounds.comp (uStepBounds blank dflt) (Bounds.snd : Bounds (Prod.snd : CCfg Q S → UCfg Q S)))).congr rfl +/-- A certificate for the counting loop's halting test. -/ def countHaltBounds [Fintype Q] (halting : Q → Bool) : Bounds (countHalt (S := S) halting) := (Bounds.comp (uHaltBounds halting) (Bounds.snd : Bounds (Prod.snd : CCfg Q S → UCfg Q S))).congr rfl +/-- A certificate for the counting loop's initial accumulator. -/ def countInitBounds : Bounds (countInit : UCfg Q S → CCfg Q S) := (Bounds.pair (Bounds.const ([] : List Unit)) (Bounds.id : Bounds (id : UCfg Q S → UCfg Q S))).congr rfl diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean index c802c56738..eac3a2da9a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean @@ -42,6 +42,17 @@ lemma foldAcc_length (list : α → List β) (init : α → γ) (step : γ → foldAcc list init step a (list a).length = foldFun list init step a := by simp [foldAcc, foldFun] +omit [DataEncode β] in +/-- An accumulator bound is automatically a bound on the fold's *output*, since the output is the +accumulator after the last element. Every example needs this, and so does `Bounds.fold`. -/ +lemma foldFun_size_le {list : α → List β} {init : α → γ} {step : γ → β → γ} (A : ℕ → ℕ) + (hA : ∀ (a : α) (j : ℕ), + (DataEncode.encode (foldAcc list init step a j)).size ≤ A (DataEncode.encode a).size) + (a : α) : + (DataEncode.encode (foldFun list init step a)).size ≤ A (DataEncode.encode a).size := by + rw [← foldAcc_length list init step a] + exact hA a _ + /-- **Complexity of `foldl` on multi-tape Turing machines.** @@ -115,9 +126,7 @@ def Bounds.fold {list : α → List β} {init : α → γ} {step : γ → β → (hl.outSize_mono h) outSize_mono := hA_mono computes := sorry - out_le a := by - rw [← foldAcc_length list init step a] - exact hA a _ + out_le := foldFun_size_le A hA /-- A `foldl` whose step ignores the element is iteration: the list only supplies a trip count. This is how a step *budget* on the input turns into a bounded run. -/ From 1ab12cdafc7c6d5aedd272e5b10c7295b1fe2e1b Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 1 Sep 2026 13:44:44 +0200 Subject: [PATCH 4/8] refactor --- .../Turing/MultiTape/Complexity/Bounds.lean | 27 +++++++++---- .../Complexity/Examples/InputCursor.lean | 22 +++++------ .../Complexity/Examples/ListMap.lean | 4 +- .../Complexity/Examples/ListUpdate.lean | 4 +- .../MultiTape/Complexity/Examples/Lookup.lean | 8 ++-- .../Complexity/Examples/SimConfig.lean | 6 +-- .../MultiTape/Complexity/Examples/Tape.lean | 28 +++++++------- .../Complexity/Examples/TapeStep.lean | 12 +++--- .../Complexity/Examples/Universal.lean | 38 +++++++++---------- .../MultiTape/Complexity/Primitives.lean | 16 ++++++++ 10 files changed, 95 insertions(+), 70 deletions(-) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean index c2669fadf8..5ecca3c64a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean @@ -67,21 +67,32 @@ namespace Bounds /-- Transport a certificate along an equality of functions. Used to turn a certificate for the literal shape a combinator produces into one for the function actually of interest. -/ -def congr {f g : α → β} (b : Bounds f) (h : f = g := by rfl) : Bounds g := h ▸ b - -/-- Transport leaves the time bound alone. Without this (and its siblings) the resource fields of -a transported certificate are stuck behind `Eq.rec` and cannot be read off, which would block -`Bounds.polyTimeLinSpace` for every certificate built via `congr`. -/ +def congr {f g : α → β} (b : Bounds f) (h : f = g := by rfl) : Bounds g where + time := b.time + space := b.space + outSize := b.outSize + time_mono := b.time_mono + space_mono := b.space_mono + outSize_mono := b.outSize_mono + computes := h ▸ b.computes + out_le := h ▸ b.out_le + +/-- Transport leaves the time bound alone. + +`congr` copies the resource fields *verbatim* and confines `Eq.rec` to the `Prop` fields, so this +and its siblings hold by `rfl` and a transported certificate's bounds stay definitionally readable +through any chain of retargets. Transporting the whole structure instead would leave them stuck +behind `Eq.rec`, silently disabling `Bounds.polyTimeLinSpace` for every derived certificate. -/ @[simp] lemma congr_time {f g : α → β} (b : Bounds f) (h : f = g) : - (b.congr h).time = b.time := by cases h; rfl + (b.congr h).time = b.time := rfl /-- Transport leaves the space bound alone. -/ @[simp] lemma congr_space {f g : α → β} (b : Bounds f) (h : f = g) : - (b.congr h).space = b.space := by cases h; rfl + (b.congr h).space = b.space := rfl /-- Transport leaves the output-size bound alone. -/ @[simp] lemma congr_outSize {f g : α → β} (b : Bounds f) (h : f = g) : - (b.congr h).outSize = b.outSize := by cases h; rfl + (b.congr h).outSize = b.outSize := rfl /-- Weaken all three bounds at once. Composition produces one specific closed form; this is how one restates it more readably. -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean index cfca67c4f2..0765eb978c 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean @@ -61,31 +61,31 @@ variable [DataEncode α] /-- Reading the cursor is taking the head of its second component. -/ def cursorReadBounds (d : α) : Bounds (cursorRead d) := (Bounds.comp (Bounds.headD d) - (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))).congr rfl + Bounds.snd) /-- Moving right: test whether the tail is empty, then either do nothing or shift one cell. -/ def cursorRBounds (d : α) : Bounds (cursorR d) := (Bounds.ite (Bounds.comp Bounds.isEmpty - (Bounds.comp Bounds.tail (Bounds.snd : Bounds (Prod.snd : Cursor α → List α)))) - (Bounds.id : Bounds (id : Cursor α → Cursor α)) + (Bounds.comp Bounds.tail Bounds.snd)) + Bounds.id (Bounds.pair (Bounds.cons (Bounds.comp (Bounds.headD d) - (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))) - (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) + Bounds.snd) + Bounds.fst) (Bounds.comp Bounds.tail - (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))))).congr rfl + Bounds.snd))) /-- Moving left. -/ def cursorLBounds (d : α) : Bounds (cursorL d) := (Bounds.ite - (Bounds.comp Bounds.isEmpty (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) - (Bounds.id : Bounds (id : Cursor α → Cursor α)) + (Bounds.comp Bounds.isEmpty Bounds.fst) + Bounds.id (Bounds.pair - (Bounds.comp Bounds.tail (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) + (Bounds.comp Bounds.tail Bounds.fst) (Bounds.cons (Bounds.comp (Bounds.headD d) - (Bounds.fst : Bounds (Prod.fst : Cursor α → List α))) - (Bounds.snd : Bounds (Prod.snd : Cursor α → List α))))).congr rfl + Bounds.fst) + Bounds.snd))) /-! ### The input tape as a finite list -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean index 76b58b61e5..b277790b92 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean @@ -120,8 +120,8 @@ def mapBounds (f : α → β) (c : ℕ) (hstep : Bounds (Function.uncurry (mapStep f))) (h_out : ∀ x : α, (DataEncode.encode (f x)).size ≤ c * (DataEncode.encode x).size) : Bounds (fun l : List α => l.map f) := - (Bounds.fold (Bounds.id : Bounds (id : List α → List α)) - (Bounds.const [] : Bounds (mapInit : List α → List β)) hstep + (Bounds.fold Bounds.id + (Bounds.const []) hstep (fun n => 2 + c * n) (by intro x y h; exact Nat.add_le_add_left (Nat.mul_le_mul_left c h) 2) (mapAccSize f c h_out)).congr (funext (foldFun_map f)) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean index f175b4944c..4f0dc33ff7 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean @@ -260,8 +260,8 @@ theorem listUpdate_polyTimeLinSpace [DataEncode α] /-- Taking the list component is two projections. -/ def listBounds [DataEncode α] : Bounds (updateList (α := α)) := Bounds.congr - (Bounds.comp (Bounds.snd : Bounds (Prod.snd : α × List α → List α)) - (Bounds.snd : Bounds (Prod.snd : ℕ × α × List α → α × List α))) rfl + (Bounds.comp Bounds.snd + Bounds.snd) rfl /-- Projecting the output list out of the accumulator is the same two projections. -/ def outBounds [DataEncode α] : Bounds (updateOut (α := α)) := diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean index b15940e468..3aa38167f8 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean @@ -109,13 +109,13 @@ primitives is assumed. -/ def lookupBounds [Fintype K] [Fintype V] : Bounds (lookupFn : Table K V × K → Option V) := let hl : Bounds (lookupList : Table K V × K → Table K V) := - (Bounds.fst : Bounds (Prod.fst : Table K V × K → Table K V)).congr rfl + Bounds.fst let hi : Bounds (lookupInit : Table K V × K → K × Option V) := - (Bounds.pair (Bounds.snd : Bounds (Prod.snd : Table K V × K → K)) - (Bounds.const (none : Option V))).congr rfl + (Bounds.pair Bounds.snd + (Bounds.const (none : Option V))) let hs : Bounds (Function.uncurry (lookupStep : K × Option V → K × V → K × Option V)) := Bounds.ofFintype _ - Bounds.comp (Bounds.snd : Bounds (Prod.snd : K × Option V → Option V)) + Bounds.comp Bounds.snd (Bounds.fold hl hi hs (fun _ => accBound K V) monotone_const lookupAccSize) end Lookup diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean index 9bdf84d3c0..322537d0c9 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean @@ -96,13 +96,13 @@ def moveCursor {α : Type} (blank : α) (m : SignType) (c : Cursor α) : Cursor | .neg => cursorL blank c | .pos => cursorR blank c -@[simp] lemma moveCursor_zero {α : Type} (blank : α) (c : Cursor α) : +lemma moveCursor_zero {α : Type} (blank : α) (c : Cursor α) : moveCursor blank SignType.zero c = c := rfl -@[simp] lemma moveCursor_neg {α : Type} (blank : α) (c : Cursor α) : +lemma moveCursor_neg {α : Type} (blank : α) (c : Cursor α) : moveCursor blank SignType.neg c = cursorL blank c := rfl -@[simp] lemma moveCursor_pos {α : Type} (blank : α) (c : Cursor α) : +lemma moveCursor_pos {α : Type} (blank : α) (c : Cursor α) : moveCursor blank SignType.pos c = cursorR blank c := rfl /-- **Moving the cursor implements `moveInputPos`**, clamping included. -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean index b047a1dd6e..04b06c37a0 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean @@ -72,7 +72,7 @@ def moveL (blank : S) (t : Tape S) : Tape S := (t.1.tail, t.1.head?.getD blank : /-- Reading is the head of the right-hand list. -/ def readBounds (blank : S) : Bounds (read (S := S) blank) := - (Bounds.comp (Bounds.headD blank) Bounds.snd).congr rfl + (Bounds.comp (Bounds.headD blank) Bounds.snd) /-- Writing replaces the head of the right-hand list. -/ def writeBounds : Bounds (write : Tape S × S → Tape S) := @@ -83,12 +83,12 @@ def writeBounds : Bounds (write : Tape S × S → Tape S) := /-- Moving right pops the right-hand list and pushes onto the left-hand one. -/ def moveRBounds (blank : S) : Bounds (moveR (S := S) blank) := (Bounds.pair (Bounds.cons (Bounds.comp (Bounds.headD blank) Bounds.snd) Bounds.fst) - (Bounds.comp Bounds.tail Bounds.snd)).congr rfl + (Bounds.comp Bounds.tail Bounds.snd)) /-- Moving left pops the left-hand list and pushes onto the right-hand one. -/ def moveLBounds (blank : S) : Bounds (moveL (S := S) blank) := (Bounds.pair (Bounds.comp Bounds.tail Bounds.fst) - (Bounds.cons (Bounds.comp (Bounds.headD blank) Bounds.fst) Bounds.snd)).congr rfl + (Bounds.cons (Bounds.comp (Bounds.headD blank) Bounds.fst) Bounds.snd)) /-! ### How much the tape can grow @@ -176,22 +176,20 @@ def applyInstr (blank : S) (p : Instr Q S × (Q × Tape S)) : Q × Tape S := def applyInstrBounds (blank : S) : Bounds (applyInstr (Q := Q) blank) := let i : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1) := Bounds.fst let st : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1.1) := - (Bounds.comp (Bounds.fst : Bounds (Prod.fst : Instr Q S → Q)) i).congr rfl + (Bounds.comp Bounds.fst i) let sym : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1.2.1) := - (Bounds.comp (Bounds.comp (Bounds.fst : Bounds (Prod.fst : S × Bool → S)) - (Bounds.snd : Bounds (Prod.snd : Instr Q S → S × Bool))) i).congr rfl + Bounds.comp' _ (Bounds.comp Bounds.fst Bounds.snd) i let dir : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1.2.2) := - (Bounds.comp (Bounds.comp (Bounds.snd : Bounds (Prod.snd : S × Bool → Bool)) - (Bounds.snd : Bounds (Prod.snd : Instr Q S → S × Bool))) i).congr rfl + Bounds.comp' _ (Bounds.comp Bounds.snd Bounds.snd) i let tp : Bounds (fun p : Instr Q S × (Q × Tape S) => p.2.2) := - (Bounds.comp (Bounds.snd : Bounds (Prod.snd : Q × Tape S → Tape S)) - (Bounds.snd : Bounds (Prod.snd : Instr Q S × (Q × Tape S) → Q × Tape S))).congr rfl + (Bounds.comp Bounds.snd + Bounds.snd) let written : Bounds (fun p : Instr Q S × (Q × Tape S) => write (p.2.2, p.1.2.1)) := - (Bounds.comp writeBounds (Bounds.pair tp sym)).congr rfl + (Bounds.comp writeBounds (Bounds.pair tp sym)) (Bounds.pair st (Bounds.ite dir (Bounds.comp (moveRBounds blank) written) - (Bounds.comp (moveLBounds blank) written))).congr rfl + (Bounds.comp (moveLBounds blank) written))) /-! ### One step of a simulated machine with a fixed transition function -/ @@ -205,12 +203,12 @@ def simStepBounds [Fintype Q] [Fintype S] (blank : S) (tr : Q × S → Instr Q S Bounds (simStep blank tr) := let rd : Bounds (fun c : Q × Tape S => read blank c.2) := (Bounds.comp (readBounds blank) - (Bounds.snd : Bounds (Prod.snd : Q × Tape S → Tape S))).congr rfl + Bounds.snd) let instr : Bounds (fun c : Q × Tape S => tr (c.1, read blank c.2)) := (Bounds.comp (Bounds.ofFintype tr) - (Bounds.pair (Bounds.fst : Bounds (Prod.fst : Q × Tape S → Q)) rd)).congr rfl + (Bounds.pair Bounds.fst rd)) (Bounds.comp (applyInstrBounds blank) - (Bounds.pair instr (Bounds.id : Bounds (id : Q × Tape S → Q × Tape S)))).congr rfl + (Bounds.pair instr Bounds.id)) end Simulation diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean index d32ccb877d..6d10a16175 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean @@ -61,22 +61,22 @@ def applyAction (blank : S) (a : Option S × SignType) (t : Tape S) : Tape S := @[simp] lemma signCast_neg : ((SignType.neg : SignType) : ℤ) = -1 := rfl @[simp] lemma signCast_pos : ((SignType.pos : SignType) : ℤ) = 1 := rfl -@[simp] lemma applyAction_none_zero (blank : S) (t : Tape S) : +lemma applyAction_none_zero (blank : S) (t : Tape S) : applyAction blank (none, SignType.zero) t = t := rfl -@[simp] lemma applyAction_none_neg (blank : S) (t : Tape S) : +lemma applyAction_none_neg (blank : S) (t : Tape S) : applyAction blank (none, SignType.neg) t = moveL blank t := rfl -@[simp] lemma applyAction_none_pos (blank : S) (t : Tape S) : +lemma applyAction_none_pos (blank : S) (t : Tape S) : applyAction blank (none, SignType.pos) t = moveR blank t := rfl -@[simp] lemma applyAction_some_zero (blank : S) (s : S) (t : Tape S) : +lemma applyAction_some_zero (blank : S) (s : S) (t : Tape S) : applyAction blank (some s, SignType.zero) t = write (t, s) := rfl -@[simp] lemma applyAction_some_neg (blank : S) (s : S) (t : Tape S) : +lemma applyAction_some_neg (blank : S) (s : S) (t : Tape S) : applyAction blank (some s, SignType.neg) t = moveL blank (write (t, s)) := rfl -@[simp] lemma applyAction_some_pos (blank : S) (s : S) (t : Tape S) : +lemma applyAction_some_pos (blank : S) (s : S) (t : Tape S) : applyAction blank (some s, SignType.pos) t = moveR blank (write (t, s)) := rfl /-- **A work-tape action on the zipper implements the one `MultiTapeTM.step` performs.** -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean index 56b3d76185..85191d4795 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean @@ -70,29 +70,29 @@ def uHalt (halting : Q → Bool) (c : UCfg Q S) : Bool := halting c.2.1 /-- A certificate for the halting test. -/ def uHaltBounds [Fintype Q] (halting : Q → Bool) : Bounds (uHalt (S := S) halting) := (Bounds.comp (Bounds.ofFintype halting) - (Bounds.comp (Bounds.fst : Bounds (Prod.fst : Q × Tape S → Q)) - (Bounds.snd : Bounds (Prod.snd : UCfg Q S → Q × Tape S)))).congr rfl + (Bounds.comp Bounds.fst + Bounds.snd)) /-- **A certificate for one universal step**, composed from the table lookup and the tape operations. -/ def uStepBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) : Bounds (uStep blank dflt) := let tbl : Bounds (fun c : UCfg Q S => c.1) := - (Bounds.fst : Bounds (Prod.fst : UCfg Q S → UTable Q S)) + Bounds.fst let cfg : Bounds (fun c : UCfg Q S => c.2) := - (Bounds.snd : Bounds (Prod.snd : UCfg Q S → Q × Tape S)) + Bounds.snd let st : Bounds (fun c : UCfg Q S => c.2.1) := - (Bounds.comp (Bounds.fst : Bounds (Prod.fst : Q × Tape S → Q)) cfg).congr rfl + (Bounds.comp Bounds.fst cfg) let tp : Bounds (fun c : UCfg Q S => c.2.2) := - (Bounds.comp (Bounds.snd : Bounds (Prod.snd : Q × Tape S → Tape S)) cfg).congr rfl + (Bounds.comp Bounds.snd cfg) let rd : Bounds (fun c : UCfg Q S => read blank c.2.2) := - (Bounds.comp (readBounds blank) tp).congr rfl + (Bounds.comp (readBounds blank) tp) let look : Bounds (fun c : UCfg Q S => lookupFn (c.1, (c.2.1, read blank c.2.2))) := - (Bounds.comp lookupBounds (Bounds.pair tbl (Bounds.pair st rd))).congr rfl + Bounds.comp' _ lookupBounds (Bounds.pair tbl (Bounds.pair st rd)) let instr : Bounds (fun c : UCfg Q S => (lookupFn (c.1, (c.2.1, read blank c.2.2))).getD dflt) := - (Bounds.comp (Bounds.optionGetD dflt) look).congr rfl - (Bounds.pair tbl (Bounds.comp (applyInstrBounds blank) (Bounds.pair instr cfg))).congr rfl + (Bounds.comp (Bounds.optionGetD dflt) look) + (Bounds.pair tbl (Bounds.comp (applyInstrBounds blank) (Bounds.pair instr cfg))) /-! ### How fast a configuration can grow -/ @@ -161,7 +161,7 @@ def uRunBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) (halting : (N : ℕ → ℕ) (hN_mono : Monotone N) (hN : ∀ c, steps c ≤ N (DataEncode.encode c).size) : Bounds out := - Bounds.while (Bounds.id : Bounds (id : UCfg Q S → UCfg Q S)) + Bounds.while Bounds.id (uHaltBounds halting) (uStepBounds blank dflt) steps h_out h_halt h_first N (fun n => n + N n * stepGrowth (Q := Q) blank) hN_mono @@ -240,12 +240,12 @@ def uRunBudgetBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) (halting : Q → Bool) : Bounds (foldFun budgetList budgetInit (budgetFoldStep blank dflt halting)) := Bounds.fold - ((Bounds.fst : Bounds (Prod.fst : List Unit × UCfg Q S → List Unit)).congr rfl) - ((Bounds.snd : Bounds (Prod.snd : List Unit × UCfg Q S → UCfg Q S)).congr rfl) + (Bounds.fst) + (Bounds.snd) ((Bounds.comp - (Bounds.ite (uHaltBounds halting) (Bounds.id : Bounds (id : UCfg Q S → UCfg Q S)) + (Bounds.ite (uHaltBounds halting) Bounds.id (uStepBounds blank dflt)) - (Bounds.fst : Bounds (Prod.fst : UCfg Q S × Unit → UCfg Q S))).congr rfl) + Bounds.fst)) (fun n => n + n * stepGrowth (Q := Q) blank) (fun _ _ h => Nat.add_le_add h (Nat.mul_le_mul h (le_refl _))) (fun p j => by @@ -316,19 +316,19 @@ def countStepBounds [Fintype Q] [Fintype S] (blank : S) (dflt : Instr Q S) : Bounds (countStep blank dflt) := (Bounds.pair (Bounds.cons (Bounds.const (() : Unit)) - (Bounds.fst : Bounds (Prod.fst : CCfg Q S → List Unit))) + Bounds.fst) (Bounds.comp (uStepBounds blank dflt) - (Bounds.snd : Bounds (Prod.snd : CCfg Q S → UCfg Q S)))).congr rfl + Bounds.snd)) /-- A certificate for the counting loop's halting test. -/ def countHaltBounds [Fintype Q] (halting : Q → Bool) : Bounds (countHalt (S := S) halting) := (Bounds.comp (uHaltBounds halting) - (Bounds.snd : Bounds (Prod.snd : CCfg Q S → UCfg Q S))).congr rfl + Bounds.snd) /-- A certificate for the counting loop's initial accumulator. -/ def countInitBounds : Bounds (countInit : UCfg Q S → CCfg Q S) := (Bounds.pair (Bounds.const ([] : List Unit)) - (Bounds.id : Bounds (id : UCfg Q S → UCfg Q S))).congr rfl + Bounds.id) /-- **A certificate for a run that reports its own step count.** The output is the pair of the step count, in unary, and the halting configuration. -/ diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean index 7f2803d6da..0eddd824ce 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean @@ -269,6 +269,22 @@ def ite {c : α → Bool} {f g : α → β} (hc : Bounds c) (hf : Bounds f) (hg · simp only [Bool.cond_false]; omega · simp only [Bool.cond_true]; omega +/-- **Retargeted composition.** Like `Bounds.comp`, but with the composite named up front. + +`Bounds.comp` produces `Bounds (g ∘ f)`, and matching that against a caller's expected type runs +higher-order unification, which at *nested* compositions picks the trivial split (`g := everything`, +`f := id`) and then rejects the arguments. Naming the target makes `fg` a first-order unification +against the expected type; `f` and `g` come from the arguments; and the `autoParam` checks the +split only once everything is determined. Pass `h` explicitly for a retarget that is not `rfl`. -/ +def comp' (fg : α → γ) {f : α → β} {g : β → γ} (hg : Bounds g) (hf : Bounds f) + (h : g ∘ f = fg := by rfl) : Bounds fg := + (comp hg hf).congr h + +/-- **Retargeted fan-out**, for the same reason as `Bounds.comp'`. -/ +def pair' (fg : α → β × γ) {f : α → β} {g : α → γ} (hf : Bounds f) (hg : Bounds g) + (h : (fun a => (f a, g a)) = fg := by rfl) : Bounds fg := + (pair hf hg).congr h + /-- The unary cons, derived: pair up the two projections and cons them. -/ def consUncurried : Bounds (fun p : β × List β => p.1 :: p.2) := cons fst snd From 834704ad62215acec054e5b742da4ad63dd93398 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 1 Sep 2026 14:57:39 +0200 Subject: [PATCH 5/8] more results --- .../Machines/Turing/MultiTape/Complexity.lean | 12 + .../Turing/MultiTape/Complexity/Bounds.lean | 24 +- .../MultiTape/Complexity/BoundsAttr.lean | 47 ++ .../MultiTape/Complexity/BoundsTactic.lean | 171 +++++++ .../MultiTape/Complexity/Examples/Cnf.lean | 436 ++++++++++++++++++ .../Complexity/Examples/Synthesis.lean | 78 ++++ 6 files changed, 765 insertions(+), 3 deletions(-) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsAttr.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsTactic.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Cnf.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Synthesis.lean diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean index ab9336fbcb..e21fa8ef4a 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean @@ -11,8 +11,11 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Encoding public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Defs public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Bounds public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsAttr +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsTactic public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.While +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Cnf public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListIndex public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListMap public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListUpdate @@ -21,6 +24,7 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples. public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.LookupTable public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.MachineDesc public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Tape +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Synthesis public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeView public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.TapeStep public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.SimConfig @@ -56,6 +60,13 @@ every example's fold, all of the size bookkeeping, and the whole simulation stac is not encodable: its `workTapes` field is a family of functions `ℤ → Option Symbol`. * `Simulation.zipper_length_le_spaceUsed` — that simulation's storage is bounded by the simulated machine's `spaceUsedByTape`, *not* by its running time. +* `Cnf.formulaSat_polyTimeLinSpace` — **verifying a CNF assignment is polynomial time and linear + space**, the `SAT ∈ NP` verifier. It takes no hypotheses: the certificate chain behind it rests + only on the assumed primitives above. Seven of its ten certificates are synthesised by the + `bounds` tactic; the three that are not are exactly the folds, whose accumulator bounds a tactic + cannot invent. +* The `bounds` tactic (`Complexity/BoundsTactic.lean`) — synthesises a `Bounds` certificate for a + Lean function by recursing on its definition, using `@[bounds]`-tagged certificates as leaves. ## Layout @@ -68,6 +79,7 @@ every example's fold, all of the size bookkeeping, and the whole simulation stac | `Complexity/Primitives.lean` | the elementary building blocks (machines assumed) | | `Complexity/Fold.lean` | `foldl_computableUpTo` and `Bounds.fold` | | `Complexity/While.lean` | `Bounds.while`, unbounded iteration | +| `Complexity/BoundsAttr.lean`, `BoundsTactic.lean` | `@[bounds]` and the `bounds` tactic | Worked examples of the fold theorem: diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean index 5ecca3c64a..a22d95dd0e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean @@ -7,6 +7,7 @@ Authors: Christian Reitwiessner module public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Defs +public meta import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsAttr /-! # Resource certificates @@ -83,17 +84,18 @@ def congr {f g : α → β} (b : Bounds f) (h : f = g := by rfl) : Bounds g wher and its siblings hold by `rfl` and a transported certificate's bounds stay definitionally readable through any chain of retargets. Transporting the whole structure instead would leave them stuck behind `Eq.rec`, silently disabling `Bounds.polyTimeLinSpace` for every derived certificate. -/ -@[simp] lemma congr_time {f g : α → β} (b : Bounds f) (h : f = g) : +@[simp, boundsDefs] lemma congr_time {f g : α → β} (b : Bounds f) (h : f = g) : (b.congr h).time = b.time := rfl /-- Transport leaves the space bound alone. -/ -@[simp] lemma congr_space {f g : α → β} (b : Bounds f) (h : f = g) : +@[simp, boundsDefs] lemma congr_space {f g : α → β} (b : Bounds f) (h : f = g) : (b.congr h).space = b.space := rfl /-- Transport leaves the output-size bound alone. -/ -@[simp] lemma congr_outSize {f g : α → β} (b : Bounds f) (h : f = g) : +@[simp, boundsDefs] lemma congr_outSize {f g : α → β} (b : Bounds f) (h : f = g) : (b.congr h).outSize = b.outSize := rfl + /-- Weaken all three bounds at once. Composition produces one specific closed form; this is how one restates it more readably. -/ def weaken {f : α → β} (b : Bounds f) (t s o : ℕ → ℕ) @@ -109,6 +111,22 @@ def weaken {f : α → β} (b : Bounds f) (t s o : ℕ → ℕ) computes := b.computes.mono ht hs out_le a := le_trans (b.out_le a) (ho _) +section Weaken +variable {f : α → β} (b : Bounds f) (t s o : ℕ → ℕ) (ht_mono : Monotone t) (hs_mono : Monotone s) + (ho_mono : Monotone o) (ht : ∀ n, b.time n ≤ t n) (hs : ∀ n, b.space n ≤ s n) + (ho : ∀ n, b.outSize n ≤ o n) + +@[simp, boundsDefs] lemma weaken_time : + (b.weaken t s o ht_mono hs_mono ho_mono ht hs ho).time = t := rfl + +@[simp, boundsDefs] lemma weaken_space : + (b.weaken t s o ht_mono hs_mono ho_mono ht hs ho).space = s := rfl + +@[simp, boundsDefs] lemma weaken_outSize : + (b.weaken t s o ht_mono hs_mono ho_mono ht hs ho).outSize = o := rfl + +end Weaken + /-- Every certificate yields the coarse `ComputableUpTo` statement with the same bounds. -/ theorem toComputableUpTo {f : α → β} (b : Bounds f) : ComputableUpTo f b.time b.space := ⟨1, b.computes.mono diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsAttr.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsAttr.lean new file mode 100644 index 0000000000..f7f2d2e2c4 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsAttr.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Lean + +/-! +# The `@[bounds]` attribute + +Registers a `Bounds` certificate as a *leaf* for the `bounds` tactic. Anything already proved — +a primitive, a hand-built certificate, or the result of `Bounds.fold` / `Bounds.while` — can be +registered, and the tactic will stop its recursion there. + +This is the intended way to handle loops and recursion. `Bounds.fold` and `Bounds.while` take +arguments a tactic cannot invent (the accumulator bound `A`, the trip count `N`), so they are +deliberately *not* given tactic support; instead the human proves the certificate once and +registers it. + +The extension lives in its own module because Lean forbids using an `initialize` declaration in +the module that declares it. +-/ + +open Lean + +public section + +/-- Certificates registered as leaves for the `bounds` tactic. -/ +initialize boundsExt : SimplePersistentEnvExtension Name (Array Name) ← + registerSimplePersistentEnvExtension + { addEntryFn := Array.push + addImportedFn := fun as => as.foldl (· ++ ·) #[] } + +/-- Simp set unfolding every `Bounds` combinator, so a synthesised certificate's bounds can be +read off. Populated in `BoundsTactic.lean`, where the combinators are in scope. -/ +register_simp_attr boundsDefs + +initialize registerBuiltinAttribute { + name := `bounds + descr := "register a `Bounds` certificate as a leaf for the `bounds` tactic" + add := fun decl _ _ => modifyEnv fun env => boundsExt.addEntry env decl + } + +end diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsTactic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsTactic.lean new file mode 100644 index 0000000000..b1598e7b7a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/BoundsTactic.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives +public meta import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsAttr + +/-! +# The `bounds` tactic + +Discharges a goal `Bounds f`, for an ordinary Lean function `f`, by decomposing `f`'s term and +applying the `Bounds` combinators. This is what makes the framework usable on a large class of +Lean functions rather than only on functions whose certificates were assembled by hand. + +Note the goal is *data*: `Bounds f` is a certificate, not a proposition, so the tactic produces a +term rather than a proof. That is deliberate — the coarse `Prop`-level views (`ComputableUpTo`, +`PolyTimeLinSpace`) are not compositional, because `ComputableUpTo.comp` and `Bounds.fold` need the +*output-size* bound of their arguments in order to state their own bounds. An existential wrapper +would hide exactly the data the next combinator must mention. + +## What it handles + +The argument, constants, `Prod.mk`, projections (both `Prod.fst`/`Prod.snd` applications and +`Expr.proj`, which is what `whnf` actually produces), `List.cons`, +`List.head?.getD`, `Option.getD`, `cond`, and two application shapes — `g x` and `g x y` +where `g` itself does not mention the argument, resolved through +registered leaves. Anything else is unfolded one step at a time, consulting the leaf table before +each step so a registered function is never unfolded past. + +## What it does not handle, on purpose + +Folds and loops. `Bounds.fold` and `Bounds.while` take the accumulator bound `A` and trip count +`N`, which a tactic cannot invent. Prove the certificate once and register it with `@[bounds]`; +the tactic then treats it as a leaf. Likewise `if`: a `Decidable` `ite` elaborates to +`Decidable.rec`, which has no certificate — write `cond` instead, which is the framework's own +discipline anyway. + +## Reading the bounds back off + +A synthesised certificate's fields reduce definitionally (`Bounds.congr` copies them verbatim), so +`simp [boundsDefs]` followed by `omega` / `nlinarith` will bound them. Beware that projections +synthesise as `Bounds.comp Bounds.fst Bounds.id`, so combinators you did not write appear in the +term; `boundsDefs` collects them all. +-/ + +open Lean Meta Elab Tactic + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +attribute [boundsDefs] Bounds.id Bounds.const Bounds.fst Bounds.snd Bounds.comp Bounds.pair + Bounds.cons Bounds.ite Bounds.tail Bounds.headD Bounds.isEmpty Bounds.optionGetD + Bounds.congr Bounds.comp' Bounds.pair' + +/-- Try each registered certificate against `target`, synthesising its instance arguments. -/ +meta def tryLeaf (target : Expr) : MetaM (Option Expr) := do + for nm in boundsExt.getState (← getEnv) do + let r ← observing? do + let c ← mkConstWithFreshMVarLevels nm + let (mvars, _, ty) ← forallMetaTelescope (← inferType c) + guard (← isDefEq ty target) + for m in mvars do + let mty ← inferType m + if (← isClass? mty).isSome then m.mvarId!.assign (← synthInstance mty) + instantiateMVars (mkAppN c mvars) + if let some e := r then + unless e.hasExprMVar do return some e + return none + +/-- A registered certificate for `g` itself. -/ +meta def leafFor (g : Expr) : MetaM (Option Expr) := do + tryLeaf (← mkAppOptM ``Bounds #[none, none, none, none, some g]) + +/-- Synthesise a `Bounds` certificate for the Lean function `f`. -/ +meta partial def synthBounds (fuel : Nat) (f : Expr) : MetaM Expr := do + let f ← instantiateMVars f + -- consult the leaf table *before* unfolding, so registered functions are never unfolded past + if let some e ← leafFor f then return e + let f ← if f.isLambda then pure f else whnf f + let f ← if f.isLambda then pure f else etaExpand f + lambdaTelescope f fun xs body => do + unless xs.size == 1 do + throwError "bounds: expected a one-argument function; uncurry it first" + let a := xs[0]! + let α ← inferType a + let β ← inferType body + if body == a then return ← mkAppOptM ``Bounds.id #[some α, none] + if !body.containsFVar a.fvarId! then + return ← mkAppOptM ``Bounds.const #[some α, some β, none, none, some body] + if let .proj ``Prod i u := body then + let bu ← synthBounds fuel (← mkLambdaFVars #[a] u) + let_expr Prod A B := ← whnf (← inferType u) | throwError "bounds: bad projection" + let head ← if i == 0 then mkAppOptM ``Bounds.fst #[some A, some B, none, none] + else mkAppOptM ``Bounds.snd #[some A, some B, none, none] + return ← mkAppM ``Bounds.comp #[head, bu] + match_expr body with + | Prod.mk _ _ u v => + return ← mkAppM ``Bounds.pair #[← synthBounds fuel (← mkLambdaFVars #[a] u), + ← synthBounds fuel (← mkLambdaFVars #[a] v)] + | List.cons _ u v => + return ← mkAppM ``Bounds.cons #[← synthBounds fuel (← mkLambdaFVars #[a] u), + ← synthBounds fuel (← mkLambdaFVars #[a] v)] + | Prod.fst A B u => + return ← mkAppM ``Bounds.comp + #[← mkAppOptM ``Bounds.fst #[some A, some B, none, none], + ← synthBounds fuel (← mkLambdaFVars #[a] u)] + | Prod.snd A B u => + return ← mkAppM ``Bounds.comp + #[← mkAppOptM ``Bounds.snd #[some A, some B, none, none], + ← synthBounds fuel (← mkLambdaFVars #[a] u)] + | List.tail E u => + return ← mkAppM ``Bounds.comp + #[← mkAppOptM ``Bounds.tail #[some E, none], + ← synthBounds fuel (← mkLambdaFVars #[a] u)] + | Option.getD E h d => + match_expr h with + | List.head? _ u => + return ← mkAppM ``Bounds.comp + #[← mkAppOptM ``Bounds.headD #[some E, none, some d], + ← synthBounds fuel (← mkLambdaFVars #[a] u)] + | _ => + return ← mkAppM ``Bounds.comp + #[← mkAppOptM ``Bounds.optionGetD #[some E, none, some d], + ← synthBounds fuel (← mkLambdaFVars #[a] h)] + | cond _ c t e => + return ← mkAppM ``Bounds.ite #[← synthBounds fuel (← mkLambdaFVars #[a] c), + ← synthBounds fuel (← mkLambdaFVars #[a] t), + ← synthBounds fuel (← mkLambdaFVars #[a] e)] + | _ => pure () + -- `g x`, and `g x y`, where `g` itself does not mention the argument + if let .app g x := body then + if !g.containsFVar a.fvarId! then + if let some cert ← leafFor g then + return ← mkAppM ``Bounds.comp #[cert, ← synthBounds fuel (← mkLambdaFVars #[a] x)] + if let .app g' y := g then + if !g'.containsFVar a.fvarId! then + if let some cert ← leafFor (← mkAppM ``Function.uncurry #[g']) then + return ← mkAppM ``Bounds.comp + #[cert, ← mkAppM ``Bounds.pair + #[← synthBounds fuel (← mkLambdaFVars #[a] y), + ← synthBounds fuel (← mkLambdaFVars #[a] x)]] + if fuel == 0 then throwError "bounds: out of fuel at{indentExpr body}" + match ← unfoldDefinition? body with + | some body' => synthBounds (fuel - 1) (← mkLambdaFVars #[a] (← whnfCore body')) + | none => + throwError "bounds: no rule for{indentExpr body}\n\ + Register a certificate for it with `@[bounds]`, or rewrite it using `cond`." + +/-- Synthesise a resource certificate for the function in the goal. -/ +elab "bounds" : tactic => do + let goal ← getMainGoal + let ty ← whnf (← goal.getType) + let_expr Bounds _ _ _ _ f := ty | throwError "bounds: goal is not a `Bounds` goal" + let e ← synthBounds 100 f + let ety ← inferType e + unless ← isDefEq ety ty do + throwError "bounds: synthesised a certificate of type{indentExpr ety}" + goal.assign e + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Cnf.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Cnf.lean new file mode 100644 index 0000000000..051cc04bb3 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Cnf.lean @@ -0,0 +1,436 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsTactic + +/-! +# Checking a CNF assignment is polynomial time + +The standard verifier for `SAT ∈ NP`: given an assignment and a formula in conjunctive normal +form, decide whether the assignment satisfies it. + +It is two nested folds. The outer one walks the clauses conjunctively; the inner one walks a +clause's literals disjunctively. Both carry the **assignment inside the accumulator**, because a +`foldl` step in this framework deliberately never sees the original input — the design decision +made when `foldl_computableUpTo` was stated. That is what keeps the accumulator bound linear: +the assignment is a component of the input, so carrying it costs `n + O(1)`, not more. + +Variable lookup is `asg[i]?`, which is the fold already worked out in `Examples/ListIndex.lean`. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +namespace Cnf + +/-- A variable, named by a unary index. Unary rather than binary so that looking a variable up in +the assignment is a fold over *existing* primitives (drop one cell per tick) rather than needing +`ℕ` arithmetic, for which this framework has no certificate. Unary and binary indices are +polynomially related, so the polynomial-time claim is unaffected. -/ +abbrev Var := List Unit + +/-- A literal: a variable together with the polarity that satisfies it. -/ +abbrev Lit := Var × Bool + +/-- A clause is a disjunction of literals. -/ +abbrev Clause := List Lit + +/-- A formula in conjunctive normal form. -/ +abbrev Formula := List Clause + +/-- An assignment; variables past the end read as `false`. -/ +abbrev Assignment := List Bool + +/-! ### Variable lookup, as a fold + +Ticking one cell off the assignment per unit of the index. The step is `fun acc _ => acc.tail`, +whose certificate is `Bounds.comp Bounds.tail Bounds.fst` — primitives only. -/ + +/-- The unary index to walk. -/ +def varList (p : Assignment × Var) : Var := p.2 + +/-- Start from the whole assignment. -/ +def varInit (p : Assignment × Var) : Assignment := p.1 + +/-- Drop one cell per unit of the index. -/ +def varStep (acc : Assignment) (_ : Unit) : Assignment := acc.tail + +/-- The value of a variable under an assignment; variables past the end read as `false`. -/ +def varVal (p : Assignment × Var) : Bool := + (foldFun varList varInit varStep p).head?.getD false + +/-- **The lookup fold drops one cell per tick.** -/ +lemma foldFun_var (p : Assignment × Var) : + foldFun varList varInit varStep p = List.tail^[p.2.length] p.1 := + foldl_const_iterate _ _ _ + +lemma foldAcc_var (p : Assignment × Var) (j : ℕ) : + foldAcc varList varInit varStep p j = List.tail^[(p.2.take j).length] p.1 := + foldl_const_iterate _ _ _ + +/-- Dropping cells never grows the encoding. -/ +lemma size_tail_iterate_le (asg : Assignment) (k : ℕ) : + (DataEncode.encode (List.tail^[k] asg)).size ≤ (DataEncode.encode asg).size := by + induction k generalizing asg with + | zero => simp + | succ k ih => + rw [Function.iterate_succ_apply] + exact le_trans (ih _) (DataEncode.size_tail_le asg) + +/-- **The lookup accumulator is a suffix of the assignment**, hence never bigger than the input. -/ +lemma varAccSize (p : Assignment × Var) (j : ℕ) : + (DataEncode.encode (foldAcc varList varInit varStep p j)).size + ≤ (DataEncode.encode p).size := by + obtain ⟨asg, i⟩ := p + rw [foldAcc_var] + simp only [] + have h1 := size_tail_iterate_le asg ((i.take j).length) + have h2 : (DataEncode.encode ((asg, i) : Assignment × Var)).size + = (DataEncode.encode asg).size + (DataEncode.encode i).size + 2 := + DataEncode.size_pair _ _ + omega + +/-- A certificate for the lookup fold. The accumulator bound is the human's contribution; the +three ingredient certificates are primitives. -/ +def varFoldBounds : Bounds (foldFun varList varInit varStep) := + Bounds.fold (list := varList) (init := varInit) (step := varStep) + Bounds.snd Bounds.fst (Bounds.comp Bounds.tail Bounds.fst) + (fun n => n) monotone_id varAccSize + +/-- A certificate for variable lookup. -/ +def varValBounds : Bounds varVal := + Bounds.comp (Bounds.headD false) varFoldBounds + +attribute [bounds] varValBounds + +/-- Is a literal satisfied by an assignment? -/ +def litSat (asg : Assignment) (l : Lit) : Bool := varVal (asg, l.1) == l.2 + +/-- Is a clause satisfied? -/ +def clauseSat (asg : Assignment) (c : Clause) : Bool := c.any (litSat asg) + +/-- Is a formula satisfied? -/ +def formulaSat (p : Assignment × Formula) : Bool := p.2.all (clauseSat p.1) + +/-! ### Boolean connectives + +Functions between finite types, so `Bounds.ofFintype` covers them. Registering them lets the +tactic resolve `||`, `&&` and `==` wherever they appear. -/ + +/-- Every `Bool × Bool` encodes in at most ten cells, so `ofFintype`'s time constant for a +Boolean connective is at most fourteen. -/ +lemma sup_pair_le (f : Bool × Bool → Bool) : + (Finset.univ.sup fun a : Bool × Bool => + (DataEncode.encode a).size + (DataEncode.encode (f a)).size) ≤ 14 := by + refine Finset.sup_le fun a _ => ?_ + obtain ⟨x, y⟩ := a + have h1 := DataEncode.size_bool x + have h2 := DataEncode.size_bool y + have h3 := DataEncode.size_bool (f (x, y)) + rw [DataEncode.size_pair] + omega + +/-- …and its output constant at most four. -/ +lemma sup_out_le (f : Bool × Bool → Bool) : + (Finset.univ.sup fun a : Bool × Bool => (DataEncode.encode (f a)).size) ≤ 4 := + Finset.sup_le fun _ _ => DataEncode.size_bool _ + +/-- Disjunction. -/ +def orBounds : Bounds (Function.uncurry (· || · : Bool → Bool → Bool)) := Bounds.ofFintype _ + +/-- Conjunction. -/ +def andBounds : Bounds (Function.uncurry (· && · : Bool → Bool → Bool)) := Bounds.ofFintype _ + +/-- Boolean equality. -/ +def beqBounds : Bounds (Function.uncurry (· == · : Bool → Bool → Bool)) := Bounds.ofFintype _ + +attribute [bounds] orBounds andBounds beqBounds + +/-- `n ↦ c * (n + 1) ^ k` is monotone; the closed forms below are all of this shape. -/ +lemma mono_poly (c k : ℕ) : Monotone (fun n => c * (n + 1) ^ k) := + fun _ _ h => Nat.mul_le_mul le_rfl (Nat.pow_le_pow_left (by omega) _) + +/-- The linear case, stated without the exponent. -/ +lemma mono_lin (c : ℕ) : Monotone (fun n => c * (n + 1)) := + fun _ _ h => Nat.mul_le_mul le_rfl (by omega) + +/-- **A certificate for literal evaluation, synthesised.** -/ +def litSatBounds₀ : Bounds (Function.uncurry litSat) := by bounds + +/-- The same certificate, weakened to a closed form. + +Every combinator glues its operands' bound *expressions* together, so a certificate built by +four nested composites carries a bound tree that is exponentially large in the nesting depth even +though the function it bounds is small. Weakening to a closed form at each stage keeps the tree +flat, which is what makes the final read-off in `formulaSat_polyTimeLinSpace` tractable. -/ +def litSatBounds : Bounds (Function.uncurry litSat) := + litSatBounds₀.weaken (fun n => 100 * (n + 1) ^ 2) (fun n => 200 * (n + 1)) (fun _ => 4) + (mono_poly 100 2) (mono_lin 200) monotone_const + (fun n => by + have b3 := sup_pair_le (Function.uncurry (· == · : Bool → Bool → Bool)) + have u := DataEncode.size_bool false + have hexp : (n + 1) ^ 2 = n * n + 2 * n + 1 := by ring + rw [hexp] + simp only [boundsDefs, litSatBounds₀, varValBounds, varFoldBounds, + beqBounds, Bounds.ofFintype, Bounds.fold] + nlinarith [b3, u, Nat.zero_le n, Nat.mul_le_mul u (le_refl n)]) + (fun n => by + have b3 := sup_pair_le (Function.uncurry (· == · : Bool → Bool → Bool)) + have c3 := sup_out_le (Function.uncurry (· == · : Bool → Bool → Bool)) + have t := DataEncode.size_bool true + have u := DataEncode.size_bool false + simp only [boundsDefs, litSatBounds₀, varValBounds, varFoldBounds, + beqBounds, Bounds.ofFintype, Bounds.fold] + omega) + (fun n => by + have c3 := sup_out_le (Function.uncurry (· == · : Bool → Bool → Bool)) + simp only [boundsDefs, litSatBounds₀, varValBounds, varFoldBounds, + beqBounds, Bounds.ofFintype, Bounds.fold] + omega) + +attribute [bounds] litSatBounds + +/-! ### The inner fold: one clause -/ + +/-- The literals of the clause. -/ +def clauseList (p : Assignment × Clause) : Clause := p.2 + +/-- Carry the assignment; nothing satisfied yet. -/ +def clauseInit (p : Assignment × Clause) : Assignment × Bool := (p.1, false) + +/-- Disjoin the next literal's value. -/ +def clauseStep (acc : Assignment × Bool) (l : Lit) : Assignment × Bool := + (acc.1, acc.2 || litSat acc.1 l) + +lemma foldl_clauseStep (c : Clause) (asg : Assignment) (b : Bool) : + (c.foldl clauseStep (asg, b)).2 = (b || clauseSat asg c) := by + induction c generalizing b with + | nil => simp [clauseSat] + | cons l c ih => simp [clauseStep, ih, clauseSat, Bool.or_assoc] + +lemma foldl_clauseStep_fst (c : Clause) (asg : Assignment) (b : Bool) : + (c.foldl clauseStep (asg, b)).1 = asg := by + induction c generalizing b with + | nil => rfl + | cons l c ih => simpa [clauseStep] using ih (b || litSat asg l) + +/-- **The inner fold decides one clause.** -/ +lemma foldFun_clause (p : Assignment × Clause) : + (foldFun clauseList clauseInit clauseStep p).2 = clauseSat p.1 p.2 := by + obtain ⟨asg, c⟩ := p + change (c.foldl clauseStep (asg, false)).2 = _ + rw [foldl_clauseStep] + simp + +/-! ### The outer fold: the whole formula -/ + +/-- The clauses of the formula. -/ +def formulaList (p : Assignment × Formula) : Formula := p.2 + +/-- Carry the assignment; satisfied so far. -/ +def formulaInit (p : Assignment × Formula) : Assignment × Bool := (p.1, true) + +/-- Conjoin the next clause's value. -/ +def formulaStep (acc : Assignment × Bool) (c : Clause) : Assignment × Bool := + (acc.1, acc.2 && clauseSat acc.1 c) + +lemma foldl_formulaStep (f : Formula) (asg : Assignment) (b : Bool) : + (f.foldl formulaStep (asg, b)).2 = (b && f.all (clauseSat asg)) := by + induction f generalizing b with + | nil => simp + | cons c f ih => simp [formulaStep, ih, Bool.and_assoc] + +lemma foldl_formulaStep_fst (f : Formula) (asg : Assignment) (b : Bool) : + (f.foldl formulaStep (asg, b)).1 = asg := by + induction f generalizing b with + | nil => rfl + | cons c f ih => simpa [formulaStep] using ih (b && clauseSat asg c) + +/-- **The outer fold decides the formula.** -/ +lemma foldFun_formula (p : Assignment × Formula) : + (foldFun formulaList formulaInit formulaStep p).2 = formulaSat p := by + obtain ⟨asg, f⟩ := p + change (f.foldl formulaStep (asg, true)).2 = _ + rw [foldl_formulaStep] + simp [formulaSat] + +/-! ### Size bookkeeping + +Both accumulators have the same shape — the assignment, carried unchanged, plus one `Bool` — so +both bounds are `n + 6`: linear, because the assignment is a *component of the input*. -/ + +/-- **The inner accumulator stays linear**: the assignment is carried unchanged. -/ +lemma clauseAccSize (p : Assignment × Clause) (j : ℕ) : + (DataEncode.encode (foldAcc clauseList clauseInit clauseStep p j)).size + ≤ (DataEncode.encode p).size + 6 := by + obtain ⟨asg, c⟩ := p + have hacc : foldAcc clauseList clauseInit clauseStep (asg, c) j + = ((c.take j).foldl clauseStep (asg, false)) := rfl + have hfst := foldl_clauseStep_fst (c.take j) asg false + have hsplit : (DataEncode.encode ((c.take j).foldl clauseStep (asg, false))).size + = (DataEncode.encode ((c.take j).foldl clauseStep (asg, false)).1).size + + (DataEncode.encode ((c.take j).foldl clauseStep (asg, false)).2).size + 2 := + DataEncode.size_pair _ _ + have hb := DataEncode.size_bool ((c.take j).foldl clauseStep (asg, false)).2 + rw [hacc, hsplit, hfst, DataEncode.size_pair] + omega + +/-- **The outer accumulator stays linear**, for the same reason. -/ +lemma formulaAccSize (p : Assignment × Formula) (j : ℕ) : + (DataEncode.encode (foldAcc formulaList formulaInit formulaStep p j)).size + ≤ (DataEncode.encode p).size + 6 := by + obtain ⟨asg, f⟩ := p + have hacc : foldAcc formulaList formulaInit formulaStep (asg, f) j + = ((f.take j).foldl formulaStep (asg, true)) := rfl + have hfst := foldl_formulaStep_fst (f.take j) asg true + have hsplit : (DataEncode.encode ((f.take j).foldl formulaStep (asg, true))).size + = (DataEncode.encode ((f.take j).foldl formulaStep (asg, true)).1).size + + (DataEncode.encode ((f.take j).foldl formulaStep (asg, true)).2).size + 2 := + DataEncode.size_pair _ _ + have hb := DataEncode.size_bool ((f.take j).foldl formulaStep (asg, true)).2 + rw [hacc, hsplit, hfst, DataEncode.size_pair] + omega + +/-- Deciding one clause, as a function of the pair. -/ +def clauseSatP (p : Assignment × Clause) : Bool := clauseSat p.1 p.2 + +/-! ### Certificates, bottom up + +Each *step* is synthesised by the tactic; each *fold* needs its accumulator bound supplied by +hand, and is then registered so the next level up can be synthesised in turn. -/ + +/-- Synthesised. -/ +def clauseStepBounds : Bounds (Function.uncurry clauseStep) := by bounds + +/-- Synthesised. -/ +def clauseListBounds : Bounds clauseList := by bounds + +/-- Synthesised. -/ +def clauseInitBounds : Bounds clauseInit := by bounds + +/-- The inner fold; the accumulator bound is the human's contribution. -/ +def clauseFoldBounds : Bounds (foldFun clauseList clauseInit clauseStep) := + Bounds.fold (list := clauseList) (init := clauseInit) (step := clauseStep) + clauseListBounds clauseInitBounds clauseStepBounds + (fun n => n + 6) (fun _ _ h => Nat.add_le_add_right h 6) clauseAccSize + +/-- **Deciding one clause.** -/ +def clauseSatBounds₀ : Bounds clauseSatP := + (Bounds.comp (Bounds.snd : Bounds (Prod.snd : Assignment × Bool → Bool)) + clauseFoldBounds).congr (funext foldFun_clause) + +/-- Weakened to a closed form, as for `litSatBounds`. One clause costs a cubic: the fold runs the +quadratic `litSatBounds` once per literal. -/ +def clauseSatBounds : Bounds clauseSatP := + clauseSatBounds₀.weaken (fun n => 100000 * (n + 1) ^ 3) (fun n => 20000 * (n + 1)) + (fun n => 20 * (n + 1)) (mono_poly 100000 3) (mono_lin 20000) (mono_lin 20) + (fun n => by + have b1 := sup_pair_le (Function.uncurry (· || · : Bool → Bool → Bool)) + have c1 := sup_out_le (Function.uncurry (· || · : Bool → Bool → Bool)) + have t := DataEncode.size_bool true + have u := DataEncode.size_bool false + have hexp : (n + 1) ^ 3 = n * n * n + 3 * (n * n) + 3 * n + 1 := by ring + rw [hexp] + simp only [boundsDefs, clauseSatBounds₀, clauseFoldBounds, clauseStepBounds, + clauseListBounds, clauseInitBounds, litSatBounds, orBounds, Bounds.ofFintype, Bounds.fold] + nlinarith [b1, c1, t, u, Nat.zero_le n, sq_nonneg n, + Nat.mul_le_mul u (le_refl n), Nat.mul_le_mul b1 (le_refl n), Nat.mul_le_mul c1 (le_refl n), + Nat.mul_le_mul (Nat.mul_le_mul u (le_refl n)) (le_refl n)]) + (fun n => by + have b1 := sup_pair_le (Function.uncurry (· || · : Bool → Bool → Bool)) + have c1 := sup_out_le (Function.uncurry (· || · : Bool → Bool → Bool)) + have t := DataEncode.size_bool true + have u := DataEncode.size_bool false + simp only [boundsDefs, clauseSatBounds₀, clauseFoldBounds, clauseStepBounds, + clauseListBounds, clauseInitBounds, litSatBounds, orBounds, Bounds.ofFintype, Bounds.fold] + omega) + (fun n => by + have c1 := sup_out_le (Function.uncurry (· || · : Bool → Bool → Bool)) + simp only [boundsDefs, clauseSatBounds₀, clauseFoldBounds, clauseStepBounds, + clauseListBounds, clauseInitBounds, litSatBounds, orBounds, Bounds.ofFintype, Bounds.fold] + omega) + +attribute [bounds] clauseSatBounds + +/-- Synthesised, now that `clauseSatBounds` is a leaf. -/ +def formulaStepBounds : Bounds (Function.uncurry formulaStep) := by bounds + +/-- Synthesised. -/ +def formulaListBounds : Bounds formulaList := by bounds + +/-- Synthesised. -/ +def formulaInitBounds : Bounds formulaInit := by bounds + +/-- The outer fold. -/ +def formulaFoldBounds : Bounds (foldFun formulaList formulaInit formulaStep) := + Bounds.fold (list := formulaList) (init := formulaInit) (step := formulaStep) + formulaListBounds formulaInitBounds formulaStepBounds + (fun n => n + 6) (fun _ _ h => Nat.add_le_add_right h 6) formulaAccSize + +/-- **Verifying a CNF assignment — a certificate, with no hypotheses at all.** + +Everything it rests on is the framework's assumed primitives; nothing specific to CNF is assumed. +Read the concrete time and space bounds off with `simp [boundsDefs]`. -/ +def formulaSatBounds : Bounds formulaSat := + (Bounds.comp (Bounds.snd : Bounds (Prod.snd : Assignment × Bool → Bool)) + formulaFoldBounds).congr (funext foldFun_formula) + +/-! ### The complexity statements -/ + +/-- **Verifying a CNF assignment is polynomial time and linear space.** + +This is the `SAT ∈ NP` verifier, read off from `formulaSatBounds` with no hypotheses at all: the +certificate chain rests only on the framework's assumed primitives. + +The exponent is `4`, and the nesting explains it. The outer fold visits each clause; the inner +fold visits each literal of that clause; evaluating one literal walks the assignment to find the +variable. That is three nested linear scans, and the fold combinator charges the per-step bound at +the *accumulator* size rather than the element size, which contributes the fourth factor. The +constants are deliberately loose — `PolyTimeLinSpace` quotients them away, so there is nothing to +gain by tightening them. -/ +theorem formulaSat_polyTimeLinSpace : PolyTimeLinSpace formulaSat := + formulaSatBounds.polyTimeLinSpace 10000000000 4 500000 + (fun n => le_trans + (by + have b2 := sup_pair_le (Function.uncurry (· && · : Bool → Bool → Bool)) + have c2 := sup_out_le (Function.uncurry (· && · : Bool → Bool → Bool)) + have t := DataEncode.size_bool true + have u := DataEncode.size_bool false + have hexp : (n + 1) ^ 4 = n*n*n*n + 4*(n*n*n) + 6*(n*n) + 4*n + 1 := by ring + rw [hexp] + simp only [boundsDefs, formulaSatBounds, formulaFoldBounds, formulaStepBounds, + formulaListBounds, formulaInitBounds, clauseSatBounds, andBounds, Bounds.ofFintype, + Bounds.fold] + nlinarith [b2, c2, t, u, Nat.zero_le n, sq_nonneg n, + Nat.mul_le_mul t (le_refl n), Nat.mul_le_mul c2 (le_refl n), + Nat.mul_le_mul b2 (le_refl n), + Nat.mul_le_mul (Nat.mul_le_mul t (le_refl n)) (le_refl n), + Nat.mul_le_mul (Nat.mul_le_mul (Nat.mul_le_mul t (le_refl n)) (le_refl n)) (le_refl n)] : + formulaSatBounds.time n ≤ 10000000000 * (n + 1) ^ 4) + (Nat.mul_le_mul le_rfl (Nat.pow_le_pow_left (by omega) 4))) + (fun n => by + have b2 := sup_pair_le (Function.uncurry (· && · : Bool → Bool → Bool)) + have c2 := sup_out_le (Function.uncurry (· && · : Bool → Bool → Bool)) + have t := DataEncode.size_bool true + have u := DataEncode.size_bool false + simp only [boundsDefs, formulaSatBounds, formulaFoldBounds, formulaStepBounds, + formulaListBounds, formulaInitBounds, clauseSatBounds, andBounds, Bounds.ofFintype, + Bounds.fold] + omega) + +end Cnf + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Synthesis.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Synthesis.lean new file mode 100644 index 0000000000..71293ccc48 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Synthesis.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsTactic +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Tape +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Lookup + +/-! +# Certificates, synthesised + +The `bounds` tactic applied to real functions. Each of the tape operations below already has a +hand-written certificate in `Examples/Tape.lean`; here the same certificates are produced from the +function definitions alone. + +The last section shows the point of `@[bounds]`: a loop's certificate cannot be synthesised — the +accumulator bound is a human's job — but once proved and registered, the tactic uses it as a leaf +and keeps going through everything built on top. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine Simulation + +/-! ### Tape operations, from their definitions -/ + +example (S : Type) [DataEncode S] : Bounds (Simulation.write : Tape S × S → Tape S) := by bounds + +example (S : Type) [DataEncode S] (blank : S) : Bounds (Simulation.moveR blank) := by bounds + +example (S : Type) [DataEncode S] (blank : S) : Bounds (Simulation.moveL blank) := by bounds + +example (S : Type) [DataEncode S] (blank : S) : Bounds (Simulation.read blank) := by bounds + +/-! ### Functions that never had a certificate -/ + +example (α : Type) [DataEncode α] : + Bounds (fun p : α × α × α => (p.2.2, (p.1, p.2.1))) := by bounds + +example (α : Type) [DataEncode α] : + Bounds (fun p : Bool × α × α => cond p.1 p.2.1 p.2.2) := by bounds + +example (α : Type) [DataEncode α] : + Bounds (fun p : List α × List α => (p.2.tail, p.1)) := by bounds + +/-! ### Registered leaves + +`Bounds.isEmpty` is a primitive; registering it lets the tactic resolve applications of +`List.isEmpty`, which it has no structural rule for. -/ + +attribute [bounds] Bounds.isEmpty + +example (α : Type) [DataEncode α] : + Bounds (fun p : List α × List α => (p.1.isEmpty, p.2.isEmpty)) := by bounds + +/-! ### A fold's certificate, registered + +`Lookup.lookupBounds` is built with `Bounds.fold`: its accumulator bound is supplied by hand, +which is exactly what a tactic cannot invent. Registering it turns it into a leaf, and everything +built on top is synthesised again. -/ + +attribute [bounds] Lookup.lookupBounds + +example (K V : Type) [DataEncode K] [DataEncode V] [BEq K] [Fintype K] [Fintype V] : + Bounds (fun p : (Lookup.Table K V × K) × (Lookup.Table K V × K) => + (Lookup.lookupFn p.2, Lookup.lookupFn p.1)) := by bounds + +end MultiTapeTM + +end Turing From bad3a6ce29c954226d605efd77f2d192e8f8b0c2 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 1 Sep 2026 18:01:16 +0000 Subject: [PATCH 6/8] feat(Complexity): depth-bounded recursion, and Savitch's algorithm MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Bounds.depthRec certifies functions defined by recursion whose depth depends on the input. This is the shape behind Savitch's theorem, and it is genuinely new: fold and while reuse tapes across iterations, so their space is the max over iterations, whereas a recursive call must keep its own frame live while the call beneath it runs. Space is therefore additive down the depth and max across the breadth. It adds no `sorry` — the primitive count stays at 18. The recursion is compiled to a while loop over an explicit stack, which is the algorithmic content of Savitch's theorem, so it gets proved rather than assumed. Four lemmas carry it: * complete the stack machine implements the recursion * complete_le/steps_le a step-count measure bounds the halting time (N) * stack_length_le strictly decreasing levels bound the stack (D) * frame_inv a schema-level invariant transfers to every reachable state (F, B) The last two exist because the first draft stated F and B over mstep^[j], which would have forced every caller to reason about the machine; and because Nat.find alone gives no bound, leaving N unprovable in practice. Both gaps only showed up on instantiation. Algorithms are presented as a RecSchema: a resumable state machine that either returns or asks one sub-question. Enumeration by counting and several calls per step are then just states, so nothing of the size of the search space is ever materialised. Examples/Reach.lean instantiates it with the double recursion behind Savitch's theorem and proves heval — the schema computes reach — by induction on the level, with no machine reasoning. The resource bounds (D, F, B, N and the field certificates) are not done yet. Also adds, both free of new assumptions: * DataEncode.ofInjection — encode a structure through an injection * Bounds.recode — a certificate for any encoding-preserving map, derived from Bounds.id, since DataComputableInTimeAndSpace mentions only encodings. Together these make `structure`s usable: field accessors become ordinary fst/snd chains. Co-Authored-By: Claude Opus 5 (1M context) --- .../Machines/Turing/MultiTape/Complexity.lean | 3 + .../Turing/MultiTape/Complexity/DepthRec.lean | 553 ++++++++++++++++++ .../Turing/MultiTape/Complexity/Encoding.lean | 13 + .../MultiTape/Complexity/Examples/Reach.lean | 244 ++++++++ .../MultiTape/Complexity/Primitives.lean | 21 + 5 files changed, 834 insertions(+) create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/DepthRec.lean create mode 100644 Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean index e21fa8ef4a..4d8b6b46d4 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean @@ -15,7 +15,9 @@ public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsAtt public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsTactic public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Fold public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.While +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.DepthRec public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Cnf +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.Reach public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListIndex public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListMap public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Examples.ListUpdate @@ -79,6 +81,7 @@ every example's fold, all of the size bookkeeping, and the whole simulation stac | `Complexity/Primitives.lean` | the elementary building blocks (machines assumed) | | `Complexity/Fold.lean` | `foldl_computableUpTo` and `Bounds.fold` | | `Complexity/While.lean` | `Bounds.while`, unbounded iteration | +| `Complexity/DepthRec.lean` | `Bounds.depthRec`, recursion whose depth depends on the input | | `Complexity/BoundsAttr.lean`, `BoundsTactic.lean` | `@[bounds]` and the `bounds` tactic | Worked examples of the fold theorem: diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/DepthRec.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/DepthRec.lean new file mode 100644 index 0000000000..fce936cf9f --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/DepthRec.lean @@ -0,0 +1,553 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.Primitives +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.While + +/-! +# Depth-bounded recursion + +`Bounds.depthRec` is the companion of `Bounds.fold` and `Bounds.while` for algorithms defined by +*recursion whose depth depends on the input*, of which the archetype is the double recursion in +Savitch's theorem. + +## Why this needs its own combinator + +`fold` and `while` share one accounting fact: iterations reuse each other's tapes, so their space +cost is the *maximum* over iterations. Recursion inverts half of that. Sibling calls do reuse each +other's tapes, but a call at depth `k+1` must keep its own frame live *while* the call at depth `k` +runs underneath it. So space is a **sum down the depth** and a max across the breadth: + +| | time | space | +| --- | --- | --- | +| `fold`, `while` | × trip count | max over iterations | +| `depthRec` | × branching ^ depth | **depth × frame** | + +That asymmetry is the whole content of Savitch's theorem. + +Note that the recursion cannot simply be unrolled into a fixed composition of primitives: its +depth depends on the input size, so unrolling would give a *family* of machines indexed by the +depth — a circuit family — rather than the single uniform machine that is wanted. + +## No new assumed machine + +Despite that, this file adds **no `sorry`**. The recursion is compiled to a `while` loop over an +explicit stack, and `Bounds.while`'s `A` argument — its bound on intermediate values — charges +that stack exactly. The stack is the algorithmic content of Savitch's theorem, so it is proved +here rather than assumed. + +## The schema + +A recursive algorithm is presented not as a Lean recursive function but as a *resumable state +machine*: each activation either returns, or asks one sub-question and waits to be resumed with +the answer. This shape is what makes the combinator general enough for Savitch. In particular the +midpoint search is a plain counter living in `σ`, so no exponentially large list of midpoints is +ever materialised, and the two recursive calls per midpoint are simply two states. + +Every field is a first-order function, which is what lets each be certified separately with the +ordinary combinators; there is deliberately no `Q ⊕ β` and no `Option`, since branching on `Bool` +is what `Bounds.ite` supports. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +open RoseTreeMachine + +variable {Q β σ : Type} + +/-- **A depth-recursive algorithm, defunctionalised.** + +An activation is a state `σ`. It either `isDone`, in which case its `answer` is the result, or it +`ask`s a sub-question, and is later `resume`d with that sub-question's answer. + +`level` is the recursion level, and the two laws say it strictly decreases when a sub-question is +entered and never increases on resumption. This is what bounds the stack depth — and, being a +well-founded measure, it is also what makes the recursion terminate. -/ +structure RecSchema (Q β σ : Type) where + /-- Begin an activation for a question. -/ + enter : Q → σ + /-- Has this activation finished? -/ + isDone : σ → Bool + /-- The result of a finished activation. -/ + answer : σ → β + /-- The sub-question an unfinished activation asks. -/ + ask : σ → Q + /-- Absorb a sub-answer and advance. -/ + resume : σ → β → σ + /-- The recursion level, bounding the stack depth. -/ + level : σ → ℕ + /-- Entering a sub-question strictly decreases the level. -/ + level_ask : ∀ s, isDone s = false → level (enter (ask s)) < level s + /-- Resuming never increases the level. -/ + level_resume : ∀ s b, level (resume s b) ≤ level s + +namespace RecSchema + +variable [Inhabited β] [Inhabited σ] (S : RecSchema Q β σ) + +/-- **What the algorithm computes.** `EvalFrom S s b` says the activation `s`, run to completion +with all its sub-questions answered recursively, returns `b`. -/ +inductive EvalFrom (S : RecSchema Q β σ) : σ → β → Prop where + /-- A finished activation returns its answer. -/ + | ret {s : σ} : S.isDone s = true → EvalFrom S s (S.answer s) + /-- An unfinished activation evaluates its sub-question, then continues. -/ + | ask {s : σ} {b' b : β} : S.isDone s = false → EvalFrom S (S.enter (S.ask s)) b' → + EvalFrom S (S.resume s b') b → EvalFrom S s b + +/-- The value of a question: run the activation it opens. -/ +def Eval (S : RecSchema Q β σ) (q : Q) (b : β) : Prop := EvalFrom S (S.enter q) b + +/-! ### The stack machine + +The state is a one-slot value register paired with a stack of activations. The register is a +`List β` rather than an `Option β` so that `List.isEmpty`, `List.head?` and `List.cons` — all of +which are already primitives — can take it apart. -/ + +/-- One step: deliver a pending answer to the caller, or advance the top activation. + +Written with `cond`, `List.head?.getD` and `List.tail` rather than by pattern matching, because +those are exactly the shapes the primitives in `Primitives.lean` certify — `mstepBounds` below +mirrors this definition constructor for constructor. -/ +def mstep (c : List β × List σ) : List β × List σ := + cond c.2.isEmpty c + (cond c.1.isEmpty + (cond (S.isDone (c.2.head?.getD default)) + ([S.answer (c.2.head?.getD default)], c.2.tail) + ([], S.enter (S.ask (c.2.head?.getD default)) :: c.2)) + ([], S.resume (c.2.head?.getD default) (c.1.head?.getD default) :: c.2.tail)) + +/-- The loop is finished when the stack is empty; the register then holds the answer. -/ +def mhalt (c : List β × List σ) : Bool := c.2.isEmpty + +/-- The starting state for a question. -/ +def minit (q : Q) : List β × List σ := ([], [S.enter q]) + +variable {S} + +@[simp] lemma mstep_deliver (b : β) (r : List β) (s : σ) (st : List σ) : + S.mstep (b :: r, s :: st) = ([], S.resume s b :: st) := by simp [mstep] + +/-- Once the stack is empty the machine is a fixed point, which is what lets the first halting +time be read off with `Nat.find`. -/ +@[simp] lemma mstep_halted {c : List β × List σ} (h : c.2 = []) : S.mstep c = c := by + simp [mstep, h] + +lemma mstep_iterate_halted {c : List β × List σ} (h : c.2 = []) (t : ℕ) : + S.mstep^[t] c = c := Function.iterate_fixed (mstep_halted h) t + +@[simp] lemma mstep_done {s : σ} (hs : S.isDone s = true) (st : List σ) : + S.mstep ([], s :: st) = ([S.answer s], st) := by simp [mstep, hs] + +@[simp] lemma mstep_ask {s : σ} (hs : S.isDone s = false) (st : List σ) : + S.mstep ([], s :: st) = ([], S.enter (S.ask s) :: s :: st) := by simp [mstep, hs] + +/-- **The stack machine implements the recursion.** Running it on an activation pushed onto any +stack `st` returns that activation's value in the register and leaves `st` exactly as it was. + +This is the correspondence that lets `depthRec` be derived rather than assumed. -/ +theorem complete {s : σ} {b : β} (h : EvalFrom S s b) (st : List σ) : + ∃ t, (S.mstep)^[t] ([], s :: st) = ([b], st) := by + induction h generalizing st with + | ret hs => exact ⟨1, by simp [mstep, hs]⟩ + | @ask s b' b hs _ _ ih1 ih2 => + obtain ⟨t1, ht1⟩ := ih1 (s :: st) + obtain ⟨t2, ht2⟩ := ih2 st + refine ⟨t2 + 1 + t1 + 1, ?_⟩ + rw [Function.iterate_add_apply, Function.iterate_one] + have e0 : S.mstep ([], s :: st) = ([], S.enter (S.ask s) :: s :: st) := by simp [mstep, hs] + have e1 : S.mstep ([b'], s :: st) = ([], S.resume s b' :: st) := by simp [mstep] + rw [e0, Function.iterate_add_apply, ht1, Function.iterate_add_apply, Function.iterate_one, + e1, ht2] + +/-- **The completion lemma with a step count.** + +`complete` alone says the machine halts, but `depthRec`'s `N` obligation needs a *bound* on when. +`M` is a step-count measure on activations, supplied by the caller in the same spirit as `D`, `F` +and `B`: it must cover one step for a finished activation, and for an unfinished one must cover +its sub-question, its continuation, and the two steps that push and deliver. -/ +theorem complete_le {s : σ} {b : β} (h : EvalFrom S s b) (M : σ → ℕ) + (hret : ∀ s', S.isDone s' = true → 1 ≤ M s') + (hask : ∀ s' b'', S.isDone s' = false → + M (S.enter (S.ask s')) + M (S.resume s' b'') + 2 ≤ M s') + (st : List σ) : ∃ t ≤ M s, (S.mstep)^[t] ([], s :: st) = ([b], st) := by + induction h generalizing st with + | ret hs => exact ⟨1, hret _ hs, by simp [mstep, hs]⟩ + | @ask s b' b hs _ _ ih1 ih2 => + obtain ⟨t1, ht1le, ht1⟩ := ih1 (s :: st) + obtain ⟨t2, ht2le, ht2⟩ := ih2 st + have hbound := hask s b' hs + refine ⟨t2 + 1 + t1 + 1, by omega, ?_⟩ + have e0 : S.mstep ([], s :: st) = ([], S.enter (S.ask s) :: s :: st) := by simp [mstep, hs] + have e1 : S.mstep ([b'], s :: st) = ([], S.resume s b' :: st) := by simp [mstep] + rw [Function.iterate_add_apply, Function.iterate_one, e0, Function.iterate_add_apply, ht1, + Function.iterate_add_apply, Function.iterate_one, e1, ht2] + +/-! ### The depth invariant + +The stack is strictly increasing in level from the top down, because `level_ask` makes every push +strictly decrease the level and `level_resume` never raises it. Levels are naturals, so a strictly +increasing chain bounded by `L` has at most `L + 1` entries — which is exactly the statement that +the recursion depth bounds the stack height. -/ + +variable (S) + +/-- The stack is strictly increasing in level from the top down. -/ +def Ordered : List σ → Prop + | [] => True + | [_] => True + | s :: s' :: st => S.level s < S.level s' ∧ Ordered (s' :: st) + +/-- Everything reachable during a run: a register holding at most one value, and a well-ordered +stack whose levels are bounded by `L`. -/ +def Inv (L : ℕ) (c : List β × List σ) : Prop := + c.1.length ≤ 1 ∧ Ordered S c.2 ∧ ∀ s ∈ c.2, S.level s ≤ L + +variable {S} + +omit [Inhabited β] [Inhabited σ] in +lemma Ordered.tail {s : σ} {st : List σ} (h : Ordered S (s :: st)) : Ordered S st := by + cases st with + | nil => trivial + | cons s' st => exact h.2 + +omit [Inhabited β] [Inhabited σ] in +lemma Ordered.push {s : σ} {st : List σ} (h : Ordered S st) + (hlt : ∀ s', st.head? = some s' → S.level s < S.level s') : Ordered S (s :: st) := by + cases st with + | nil => trivial + | cons s' st => exact ⟨hlt s' rfl, h⟩ + +omit [Inhabited β] [Inhabited σ] in +lemma Ordered.replace_head {s t : σ} {st : List σ} (h : Ordered S (s :: st)) + (hle : S.level t ≤ S.level s) : Ordered S (t :: st) := by + cases st with + | nil => trivial + | cons s' st => exact ⟨lt_of_le_of_lt hle h.1, h.2⟩ + +omit [Inhabited β] [Inhabited σ] in +/-- **A strictly increasing chain of levels bounded by `hi` is short.** -/ +lemma Ordered.length_le {s : σ} : ∀ {st : List σ}, Ordered S (s :: st) → + ∀ hi, (∀ x ∈ s :: st, S.level x ≤ hi) → (s :: st).length + S.level s ≤ hi + 1 := by + intro st + induction st generalizing s with + | nil => + intro _ hi hhi + have := hhi s (by simp) + simp only [List.length_cons, List.length_nil] + omega + | cons s' st ih => + intro h hi hhi + have h1 : S.level s < S.level s' := h.1 + have h2 := ih h.2 hi (fun x hx => hhi x (by simp at hx ⊢; tauto)) + simp only [List.length_cons] at h2 ⊢ + omega + +/-- The invariant is preserved by one step of the machine. -/ +lemma inv_mstep {L : ℕ} {c : List β × List σ} (h : Inv S L c) : Inv S L (S.mstep c) := by + obtain ⟨r, st⟩ := c + obtain ⟨hr, hord, hlevel⟩ := h + cases r with + | cons b r => + cases st with + | nil => exact ⟨hr, hord, hlevel⟩ + | cons s st => + rw [mstep_deliver] + refine ⟨by simp, hord.replace_head (S.level_resume s b), ?_⟩ + intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · exact le_trans (S.level_resume s b) (hlevel s (by simp)) + · exact hlevel x (by simp [hx]) + | nil => + cases st with + | nil => exact ⟨hr, hord, hlevel⟩ + | cons s st => + by_cases hd : S.isDone s = true + · rw [mstep_done hd] + exact ⟨by simp, hord.tail, fun x hx => hlevel x (by simp [hx])⟩ + · simp only [Bool.not_eq_true] at hd + rw [mstep_ask hd] + refine ⟨by simp, Ordered.push hord ?_, ?_⟩ + · intro s' hs' + simp only [List.head?_cons, Option.some.injEq] at hs' + exact hs' ▸ S.level_ask s hd + · intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · exact le_trans (le_of_lt (S.level_ask s hd)) (hlevel s (by simp)) + · exact hlevel x hx + +/-- Hence by every reachable state. -/ +lemma inv_iterate {L : ℕ} {c : List β × List σ} (h : Inv S L c) (t : ℕ) : + Inv S L (S.mstep^[t] c) := by + induction t generalizing c with + | zero => simpa using h + | succ t ih => rw [Function.iterate_succ_apply]; exact ih (inv_mstep h) + +omit [Inhabited β] [Inhabited σ] in +/-- The starting state satisfies the invariant, with `L` the level of the opening activation. -/ +lemma inv_minit (q : Q) : Inv S (S.level (S.enter q)) (S.minit q) := + ⟨by simp [minit], trivial, by + intro x hx + simp only [minit, List.mem_singleton] at hx + simp [hx]⟩ + +omit [Inhabited β] [Inhabited σ] in +/-- **The recursion depth bounds the stack height.** -/ +lemma stack_length_le {L : ℕ} {c : List β × List σ} (h : Inv S L c) : + c.2.length ≤ L + 1 := by + obtain ⟨_, hord, hlevel⟩ := h + cases hc : c.2 with + | nil => simp + | cons s st => + rw [hc] at hord hlevel + have := (hord.length_le (hi := L) hlevel) + simp only [List.length_cons] at this ⊢ + omega + +/-! ### Reachable frames + +`depthRec`'s `F` and `B` obligations are about every state the machine passes through. Proving +them directly would mean reasoning about `mstep^[j]`, which is exactly the machine-level detail +the combinator exists to hide. `frame_inv` reduces them to a *schema-level* invariant: a predicate +closed under entering a sub-question and under resumption. -/ + +variable (S) + +/-- Every frame on the stack satisfies `I`, and every value in the register is the answer of some +`I`-frame. -/ +def StateInv (I : σ → Prop) (c : List β × List σ) : Prop := + (∀ s ∈ c.2, I s) ∧ ∀ b ∈ c.1, ∃ s, I s ∧ b = S.answer s + +variable {S} + +lemma stateInv_mstep {I : σ → Prop} {c : List β × List σ} + (henter : ∀ s, I s → S.isDone s = false → I (S.enter (S.ask s))) + (hresume : ∀ s b, I s → I (S.resume s b)) + (h : StateInv S I c) : StateInv S I (S.mstep c) := by + obtain ⟨r, st⟩ := c + obtain ⟨hst, hr⟩ := h + cases r with + | cons b r => + cases st with + | nil => exact ⟨hst, hr⟩ + | cons s st => + rw [mstep_deliver] + refine ⟨?_, by simp⟩ + intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · exact hresume s b (hst s (by simp)) + · exact hst x (by simp [hx]) + | nil => + cases st with + | nil => exact ⟨hst, hr⟩ + | cons s st => + by_cases hd : S.isDone s = true + · rw [mstep_done hd] + refine ⟨fun x hx => hst x (by simp [hx]), ?_⟩ + intro b hb + simp only [List.mem_singleton] at hb + exact ⟨s, hst s (by simp), hb⟩ + · simp only [Bool.not_eq_true] at hd + rw [mstep_ask hd] + refine ⟨?_, by simp⟩ + intro x hx + rcases List.mem_cons.mp hx with rfl | hx + · exact henter s (hst s (by simp)) hd + · exact hst x hx + +/-- **The schema-level invariant transfers to every reachable machine state.** This is what +discharges `depthRec`'s `F` and `B` obligations in practice. -/ +lemma frame_inv {I : σ → Prop} {q : Q} + (hinit : I (S.enter q)) + (henter : ∀ s, I s → S.isDone s = false → I (S.enter (S.ask s))) + (hresume : ∀ s b, I s → I (S.resume s b)) + (j : ℕ) : StateInv S I (S.mstep^[j] (S.minit q)) := by + induction j with + | zero => + refine ⟨?_, by simp [minit]⟩ + intro s hs + simp only [Function.iterate_zero, id_eq, minit, List.mem_singleton] at hs + exact hs ▸ hinit + | succ j ih => + rw [Function.iterate_succ_apply'] + exact stateInv_mstep henter hresume ih + +/-! ### From the machine to a certificate -/ + +section Run + +variable {α : Type} [DataEncode α] [DataEncode Q] [DataEncode β] [DataEncode σ] + {f : α → β} {mkQ : α → Q} + +omit [DataEncode α] [DataEncode Q] [DataEncode β] [DataEncode σ] in +/-- The machine halts on every question the algorithm evaluates. -/ +lemma halts (heval : ∀ a, Eval S (mkQ a) (f a)) (a : α) : + ∃ t, mhalt (S.mstep^[t] (S.minit (mkQ a))) = true := by + obtain ⟨t, ht⟩ := complete (heval a) [] + refine ⟨t, ?_⟩ + rw [show S.minit (mkQ a) = ([], S.enter (mkQ a) :: []) from rfl, ht] + simp [mhalt] + +/-- The first time the machine halts. + +Because `Nat.find` is *least*, `Bounds.while`'s `h_first` obligation is discharged here by +`Nat.find_min` rather than being forwarded to the caller, as `Universal.lean`'s `uRunBounds` +currently has to do. -/ +noncomputable def steps (heval : ∀ a, Eval S (mkQ a) (f a)) (a : α) : ℕ := + open scoped Classical in Nat.find (halts heval a) + +omit [DataEncode α] [DataEncode Q] [DataEncode β] [DataEncode σ] in +/-- **A step-count measure bounds the halting time.** This is how `depthRec`'s `N` obligation is +discharged: `Nat.find` is least, so any exhibited halting time bounds it. -/ +lemma steps_le (heval : ∀ a, Eval S (mkQ a) (f a)) (M : σ → ℕ) + (hret : ∀ s', S.isDone s' = true → 1 ≤ M s') + (hask : ∀ s' b'', S.isDone s' = false → + M (S.enter (S.ask s')) + M (S.resume s' b'') + 2 ≤ M s') + (a : α) : steps heval a ≤ M (S.enter (mkQ a)) := by + obtain ⟨t, hle, ht⟩ := complete_le (heval a) M hret hask [] + refine le_trans (Nat.find_le ?_) hle + rw [show S.minit (mkQ a) = ([], S.enter (mkQ a) :: []) from rfl, ht] + simp [mhalt] + +omit [DataEncode α] [DataEncode Q] [DataEncode β] [DataEncode σ] in +/-- **At the halting time the register holds the answer and the stack is empty.** -/ +lemma run_eq (heval : ∀ a, Eval S (mkQ a) (f a)) (a : α) : + S.mstep^[steps heval a] (S.minit (mkQ a)) = ([f a], []) := by + obtain ⟨t, ht⟩ := complete (heval a) [] + have hmi : S.minit (mkQ a) = ([], S.enter (mkQ a) :: []) := rfl + have hle : steps heval a ≤ t := Nat.find_le (by rw [hmi, ht]; simp [mhalt]) + have hspec : mhalt (S.mstep^[steps heval a] (S.minit (mkQ a))) = true := + Nat.find_spec (halts heval a) + have hempty : (S.mstep^[steps heval a] (S.minit (mkQ a))).2 = [] := by + simpa [mhalt, List.isEmpty_iff] using hspec + have hfix : S.mstep^[t] (S.minit (mkQ a)) = S.mstep^[steps heval a] (S.minit (mkQ a)) := by + rw [show t = (t - steps heval a) + steps heval a by omega, Function.iterate_add_apply] + exact mstep_iterate_halted hempty _ + rw [← hfix, hmi, ht] + +omit [DataEncode α] [DataEncode Q] in +/-- **The reachable states are small.** The register holds at most one value, and the stack is no +taller than the recursion depth — this is where `depth × frame` enters the space bound. -/ +lemma state_size_le (a : α) (j : ℕ) (D F B : ℕ) + (hD : S.level (S.enter (mkQ a)) ≤ D) + (hF : ∀ s ∈ (S.mstep^[j] (S.minit (mkQ a))).2, (DataEncode.encode s).size ≤ F) + (hB : ∀ b ∈ (S.mstep^[j] (S.minit (mkQ a))).1, (DataEncode.encode b).size ≤ B) : + (DataEncode.encode (S.mstep^[j] (S.minit (mkQ a)))).size ≤ B + F * (D + 1) + 6 := by + obtain ⟨hreg, hord, hlevel⟩ := inv_iterate (inv_minit (S := S) (mkQ a)) j + have hlen : (S.mstep^[j] (S.minit (mkQ a))).2.length ≤ D + 1 := + le_trans (stack_length_le ⟨hreg, hord, hlevel⟩) (by omega) + have hsum2 := sum_map_le _ (fun s => (DataEncode.encode s).size) F hF + have hsum1 := sum_map_le _ (fun b => (DataEncode.encode b).size) B hB + have e : (DataEncode.encode (S.mstep^[j] (S.minit (mkQ a)))).size + = (DataEncode.encode (S.mstep^[j] (S.minit (mkQ a))).1).size + + (DataEncode.encode (S.mstep^[j] (S.minit (mkQ a))).2).size + 2 := + DataEncode.size_pair _ _ + rw [e, DataEncode.size_list, DataEncode.size_list] + have h1 : B * (S.mstep^[j] (S.minit (mkQ a))).1.length ≤ B := by + calc B * (S.mstep^[j] (S.minit (mkQ a))).1.length ≤ B * 1 := Nat.mul_le_mul_left _ hreg + _ = B := by omega + have h2 : F * (S.mstep^[j] (S.minit (mkQ a))).2.length ≤ F * (D + 1) := + Nat.mul_le_mul_left _ hlen + omega + +/-! ### Certificates for the machine's pieces + +Each mirrors the corresponding definition constructor for constructor, so the transports are +`rfl`. -/ + +variable (S) + +/-- A certificate for one machine step, assembled from certificates for the schema's fields. -/ +def mstepBounds (he : Bounds S.enter) (hd : Bounds S.isDone) (ha : Bounds S.answer) + (hk : Bounds S.ask) (hres : Bounds (Function.uncurry S.resume)) : Bounds S.mstep := + Bounds.ite (Bounds.comp Bounds.isEmpty Bounds.snd) Bounds.id + (Bounds.ite (Bounds.comp Bounds.isEmpty Bounds.fst) + (Bounds.ite (Bounds.comp hd (Bounds.comp (Bounds.headD default) Bounds.snd)) + (Bounds.pair + (Bounds.cons (Bounds.comp ha (Bounds.comp (Bounds.headD default) Bounds.snd)) + (Bounds.const [])) + (Bounds.comp Bounds.tail Bounds.snd)) + (Bounds.pair (Bounds.const []) + (Bounds.cons + (Bounds.comp he (Bounds.comp hk (Bounds.comp (Bounds.headD default) Bounds.snd))) + Bounds.snd))) + (Bounds.pair (Bounds.const []) + (Bounds.cons + (Bounds.comp hres + (Bounds.pair (Bounds.comp (Bounds.headD default) Bounds.snd) + (Bounds.comp (Bounds.headD default) Bounds.fst))) + (Bounds.comp Bounds.tail Bounds.snd)))) + +/-- A certificate for the starting state. -/ +def minitBounds {mkQ : α → Q} (hmk : Bounds mkQ) (he : Bounds S.enter) : + Bounds (fun a => S.minit (mkQ a)) := + Bounds.pair (Bounds.const []) (Bounds.cons (Bounds.comp he hmk) (Bounds.const [])) + +/-- A certificate for the halting test. -/ +def mhaltBounds : Bounds (mhalt : List β × List σ → Bool) := + Bounds.comp Bounds.isEmpty Bounds.snd + +end Run + +end RecSchema + +/-! ## The combinator -/ + +namespace Bounds + +open RecSchema + +variable {α : Type} [DataEncode α] [DataEncode Q] [DataEncode β] [DataEncode σ] + [Inhabited β] [Inhabited σ] + +/-- **Depth-bounded recursion.** + +`f` is computed by the schema `S`, opened at the question `mkQ a`. The four quantities a human +must invent — the analogue of `A` for `Bounds.fold` — are: + +* `N`, a bound on the total number of machine steps (the size of the call tree); +* `D`, a bound on the recursion depth, via the level of the opening activation; +* `F`, a bound on the encoded size of a single activation (the *frame*); +* `B`, a bound on the encoded size of an answer. + +The space bound is `O(D · F)`: **additive in the depth**, which is the point. -/ +noncomputable def depthRec (S : RecSchema Q β σ) {f : α → β} {mkQ : α → Q} + (hmk : Bounds mkQ) (he : Bounds S.enter) (hd : Bounds S.isDone) (ha : Bounds S.answer) + (hk : Bounds S.ask) (hres : Bounds (Function.uncurry S.resume)) + (heval : ∀ a, Eval S (mkQ a) (f a)) + (N D F B : ℕ → ℕ) (hN_mono : Monotone N) + (hA_mono : Monotone (fun n => B n + F n * (D n + 1) + 6)) + (hN : ∀ a, steps heval a ≤ N (DataEncode.encode a).size) + (hD : ∀ a, S.level (S.enter (mkQ a)) ≤ D (DataEncode.encode a).size) + (hF : ∀ (a : α) (j : ℕ), ∀ s ∈ (S.mstep^[j] (S.minit (mkQ a))).2, + (DataEncode.encode s).size ≤ F (DataEncode.encode a).size) + (hB : ∀ (a : α) (j : ℕ), ∀ b ∈ (S.mstep^[j] (S.minit (mkQ a))).1, + (DataEncode.encode b).size ≤ B (DataEncode.encode a).size) : + Bounds f := + (Bounds.comp (Bounds.headD default) + (Bounds.comp Bounds.fst + (Bounds.while (minitBounds S hmk he) mhaltBounds + (mstepBounds S he hd ha hk hres) + (steps heval) + (fun _ => rfl) + (fun a => Nat.find_spec (halts heval a)) + (fun a j hj => by + have := Nat.find_min (halts heval a) hj + simpa using this) + N (fun n => B n + F n * (D n + 1) + 6) hN_mono hA_mono hN + (fun a j _ => state_size_le a j _ _ _ (hD a) (hF a j) (hB a j))))).congr + (funext fun a => by simp only [Function.comp_apply]; rw [run_eq heval a]; rfl) + +end Bounds + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean index 27d5fdd0e1..179deed6b1 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean @@ -53,6 +53,19 @@ class DataEncode (α : Type) where /-- Encodings really are that shallow. -/ h_depth : ∀ a, (encode a).depth ≤ depth +/-- **Encode along an injection.** The workhorse for `structure`s: give an injective map to a type +that is already encodable, and the encoding, its injectivity and its depth bound all follow. + +Because `encode a` is *definitionally* `encode (f a)`, the map `f` is a no-op on encodings, and +`Bounds.recode` gives it a certificate for free. -/ +@[instance_reducible] +def DataEncode.ofInjection {α β : Type} [DataEncode β] (f : α → β) + (hf : Function.Injective f) : DataEncode α where + encode a := DataEncode.encode (f a) + h_inj := DataEncode.h_inj.comp hf + depth := DataEncode.depth β + h_depth a := DataEncode.h_depth (f a) + instance : DataEncode Bool where encode b := if b then Data.l [Data.l []] else Data.l [] h_inj := by intro a b h; cases a <;> cases b <;> simp_all diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean new file mode 100644 index 0000000000..ec68c6af49 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.DepthRec + +/-! +# Reachability by double recursion + +The algorithm behind Savitch's theorem, instantiated into `Bounds.depthRec`. + +`reach E verts k a b` asks whether there is a path from `a` to `b` of length at most `2 ^ k`, by +guessing a midpoint and recursing twice: + +``` +reach E verts (k+1) a b = verts.any fun m => reach E verts k a m && reach E verts k m b +``` + +The two recursive calls run *sequentially*, so they reuse each other's work space; only the frame +of the enclosing call stays live. That is why the space is `depth × frame` rather than +`branching ^ depth`. + +## Two encoding choices, both forced + +* **Levels are unary** (`List Unit`). The schema has to test `k = 0` and form `k - 1`, and there + is no ℕ-arithmetic primitive — but `List.isEmpty` and `List.tail` are primitives. This is the + same device `Cnf.lean` uses for variable indices, and it is harmless: unary and binary levels + are polynomially related. +* **The activation state is a `structure`** with named fields. Its `DataEncode` instance comes + from `DataEncode.ofInjection Activation.toProd`, so the encoding *is* the tuple's encoding. + `Activation.toProd` and `Activation.ofProd` are therefore no-ops on encodings and get + certificates from `Bounds.recode` without any new assumption. Field access is then an ordinary + `Bounds.fst`/`Bounds.snd` chain. + +The midpoint search is a plain `List V` carried inside the activation, so nothing of the size of +the whole search space is ever materialised — this is the point of the resumable-strategy shape +of `RecSchema`. +-/ + +@[expose] public section + +namespace Turing + +namespace MultiTapeTM + +namespace Reach + +open RoseTreeMachine RecSchema + +variable {V : Type} [DataEncode V] [DecidableEq V] [Inhabited V] + +/-- Recursion levels, in unary. -/ +abbrev Level := List Unit + +/-- A question: at what level, and between which two vertices? -/ +abbrev Question (V : Type) := Level × V × V + +/-- An activation. -/ +structure Activation (V : Type) where + /-- This activation's recursion level, in unary. -/ + level : Level + /-- The source vertex. -/ + source : V + /-- The target vertex. -/ + target : V + /-- The midpoints still to try. -/ + remaining : List V + /-- Has this activation succeeded? -/ + finished : Bool + /-- The result, meaningful once finished. -/ + result : Bool + /-- Are we awaiting the right half `m → target`? -/ + awaitingRight : Bool + +/-- The underlying tuple. Only carries the encoding across; never appears in the algorithm. -/ +def Activation.toProd (s : Activation V) : Level × V × V × List V × Bool × Bool × Bool := + (s.level, s.source, s.target, s.remaining, s.finished, s.result, s.awaitingRight) + +/-- The inverse, for building an activation from certified components. -/ +def Activation.ofProd (p : Level × V × V × List V × Bool × Bool × Bool) : Activation V := + ⟨p.1, p.2.1, p.2.2.1, p.2.2.2.1, p.2.2.2.2.1, p.2.2.2.2.2.1, p.2.2.2.2.2.2⟩ + +omit [DataEncode V] [DecidableEq V] [Inhabited V] in +lemma Activation.toProd_injective : Function.Injective (Activation.toProd (V := V)) := by + intro x y h + cases x + cases y + simp only [Activation.toProd, Prod.mk.injEq] at h + simp_all + +instance : DataEncode (Activation V) := + DataEncode.ofInjection Activation.toProd Activation.toProd_injective + +/-- An activation that is still scanning midpoints. -/ +def scanning (k : Level) (a b : V) (ms : List V) (aw : Bool) : Activation V := + { level := k, source := a, target := b, remaining := ms, finished := false, result := false, + awaitingRight := aw } + +/-- An activation that has found a midpoint and succeeded. -/ +def succeeded (k : Level) (a b : V) (ms : List V) : Activation V := + { level := k, source := a, target := b, remaining := ms, finished := true, result := true, + awaitingRight := false } + +/-- **The algorithm.** Is there a path from `a` to `b` of length at most `2 ^ k`? -/ +def reach (E : V → V → Bool) (verts : List V) : Level → V → V → Bool + | [], a, b => (a == b) || E a b + | _ :: ks, a, b => verts.any fun m => reach E verts ks a m && reach E verts ks m b + +/-- Opening an activation. A level-zero question is answered outright. -/ +def enter (E : V → V → Bool) (verts : List V) (q : Question V) : Activation V := + cond q.1.isEmpty + { level := [], source := q.2.1, target := q.2.2, remaining := [], finished := true, + result := (q.2.1 == q.2.2) || E q.2.1 q.2.2, awaitingRight := false } + (scanning q.1 q.2.1 q.2.2 verts false) + +/-- An activation is finished when it has succeeded, run out of midpoints, or is at level zero. -/ +def isDone (s : Activation V) : Bool := s.finished || s.remaining.isEmpty || s.level.isEmpty + +/-- The result of a finished activation. -/ +def answer (s : Activation V) : Bool := s.result + +/-- The sub-question: the left half `source → m`, or the right half `m → target` once the left +succeeded. -/ +def ask (s : Activation V) : Question V := + (s.level.tail, + cond s.awaitingRight (s.remaining.head?.getD default) s.source, + cond s.awaitingRight s.target (s.remaining.head?.getD default)) + +/-- Absorbing a sub-answer: a successful left half moves on to the right half, a successful right +half finishes, and any failure moves to the next midpoint. -/ +def resume (s : Activation V) (ans : Bool) : Activation V := + cond ans + (cond s.awaitingRight + { s with finished := true, result := true, awaitingRight := false } + { s with awaitingRight := true }) + { s with + remaining := s.remaining.tail, finished := false, result := false, + awaitingRight := false } + +/-- **The schema.** The level decreases on every sub-question, which is what bounds the stack. -/ +def schema (E : V → V → Bool) (verts : List V) : + RecSchema (Question V) Bool (Activation V) where + enter := enter E verts + isDone := isDone + answer := answer + ask := ask + resume := resume + level s := s.level.length + level_ask := by + intro s hs + simp only [isDone, Bool.or_eq_false_iff] at hs + obtain ⟨⟨-, hremaining⟩, hlevel⟩ := hs + have h1 : s.level ≠ [] := by + intro h; rw [h] at hlevel; simp at hlevel + simp only [enter, ask] + cases hc : (s.level.tail).isEmpty with + | true => simpa using Nat.pos_of_ne_zero (fun h => h1 (List.eq_nil_of_length_eq_zero h)) + | false => + simp only [Bool.cond_false, scanning, List.length_tail] + exact Nat.sub_lt (Nat.pos_of_ne_zero fun h => h1 (List.eq_nil_of_length_eq_zero h)) + Nat.one_pos + level_resume := by + intro s b + cases b <;> cases hw : s.awaitingRight <;> simp [resume, hw] + +/-! ## Correctness: the schema evaluates to `reach` -/ + +omit [DataEncode V] in +/-- Scanning the remaining midpoints at one level. The inner induction of `heval`. -/ +lemma scan (E : V → V → Bool) (verts : List V) (ks : Level) (u : Unit) + (ih : ∀ x y : V, EvalFrom (schema E verts) ((schema E verts).enter (ks, x, y)) + (reach E verts ks x y)) (a b : V) (ms : List V) : + EvalFrom (schema E verts) (scanning (u :: ks) a b ms false) + (ms.any fun m => reach E verts ks a m && reach E verts ks m b) := by + induction ms with + | nil => + have hd : (schema E verts).isDone (scanning (u :: ks) a b ([] : List V) false) + = true := by simp [schema, isDone, scanning] + simpa [schema, answer, scanning, succeeded] using EvalFrom.ret (S := schema E verts) hd + | cons m ms ih2 => + have hd : (schema E verts).isDone (scanning (u :: ks) a b (m :: ms) false) + = false := by simp [schema, isDone, scanning] + have hq : (schema E verts).ask (scanning (u :: ks) a b (m :: ms) false) + = (ks, a, m) := by simp [schema, ask, scanning] + rw [List.any_cons] + refine EvalFrom.ask (b' := reach E verts ks a m) hd (by rw [hq]; exact ih a m) ?_ + cases hL : reach E verts ks a m with + | false => + have he : (schema E verts).resume (scanning (u :: ks) a b (m :: ms) false) false + = (scanning (u :: ks) a b ms false) := by simp [schema, resume, scanning] + rw [he] + simpa using ih2 + | true => + have he : (schema E verts).resume (scanning (u :: ks) a b (m :: ms) false) true + = (scanning (u :: ks) a b (m :: ms) true) := by simp [schema, resume, scanning] + rw [he] + have hd2 : (schema E verts).isDone (scanning (u :: ks) a b (m :: ms) true) + = false := by simp [schema, isDone, scanning] + have hq2 : (schema E verts).ask (scanning (u :: ks) a b (m :: ms) true) + = (ks, m, b) := by simp [schema, ask, scanning] + refine EvalFrom.ask (b' := reach E verts ks m b) hd2 (by rw [hq2]; exact ih m b) ?_ + cases hR : reach E verts ks m b with + | false => + have he2 : (schema E verts).resume + (scanning (u :: ks) a b (m :: ms) true) false + = (scanning (u :: ks) a b ms false) := by simp [schema, resume, scanning] + rw [he2] + simpa using ih2 + | true => + have he2 : (schema E verts).resume + (scanning (u :: ks) a b (m :: ms) true) true + = (succeeded (u :: ks) a b (m :: ms)) := by simp [schema, resume, scanning, succeeded] + rw [he2] + have hd3 : (schema E verts).isDone (succeeded (u :: ks) a b (m :: ms)) + = true := by simp [schema, isDone, succeeded] + simpa [schema, answer, scanning, succeeded] using EvalFrom.ret (S := schema E verts) hd3 + +omit [DataEncode V] in +/-- **The schema computes `reach`.** This is `depthRec`'s `heval` obligation, and it is a plain +induction on the level — the machine never appears. -/ +lemma heval (E : V → V → Bool) (verts : List V) (k : Level) (a b : V) : + Eval (schema E verts) (k, a, b) (reach E verts k a b) := by + induction k generalizing a b with + | nil => + have hd : (schema E verts).isDone ((schema E verts).enter (([] : Level), a, b)) = true := by + simp [schema, enter, isDone, scanning] + change EvalFrom (schema E verts) ((schema E verts).enter (([] : Level), a, b)) _ + simpa [schema, enter, answer, reach, scanning] using EvalFrom.ret (S := schema E verts) hd + | cons u ks ih => + have he : (schema E verts).enter ((u :: ks : Level), a, b) + = (scanning (u :: ks) a b verts false) := by simp [schema, enter, scanning] + change EvalFrom (schema E verts) ((schema E verts).enter ((u :: ks : Level), a, b)) _ + rw [he] + simpa [reach] using scan E verts ks u (fun x y => ih x y) a b verts + +end Reach + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean index 0eddd824ce..43f4835822 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean @@ -63,6 +63,27 @@ def id : Bounds (_root_.id : α → α) where computes := sorry out_le _ := le_refl _ +/-- **Re-tagging along an encoding-preserving map.** If `f` leaves the encoding untouched then the +identity machine already computes it, so this is *derived* from `Bounds.id` rather than assumed — +note the absence of a `sorry`. + +This is what makes `structure`s usable: define `DataEncode` for a structure via +`DataEncode.ofInjection toProd`, and `toProd` (and its inverse) satisfy the hypothesis by `rfl`, +so field accessors become ordinary `Bounds.fst`/`Bounds.snd` chains. -/ +def recode {f : α → β} (h : ∀ a, DataEncode.encode (f a) = DataEncode.encode a) : Bounds f where + time n := n + 2 + space _ := 0 + outSize n := n + time_mono := fun _ _ hn => Nat.add_le_add_right hn 2 + space_mono := monotone_const + outSize_mono := monotone_id + computes := by + obtain ⟨k, sym, state, emb, tm, hm⟩ := (id (α := α)).computes + refine ⟨k, sym, state, emb, tm, fun a => ?_⟩ + obtain ⟨t', ht', s', hs', hc⟩ := hm a + exact ⟨t', ht', s', hs', by rw [h a]; exact hc⟩ + out_le a := le_of_eq (congrArg Data.size (h a)) + /-- **Constants.** Emit a fixed value; its size is a constant of the machine. -/ def const (b : β) : Bounds (fun _ : α => b) where time _ := (DataEncode.encode b).size + 2 From 3156473a98d228344a85dd6e6371978fd35a6024 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 1 Sep 2026 18:04:54 +0000 Subject: [PATCH 7/8] feat(Complexity): certificates for the reach schema's fields MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit All five RecSchema fields now have Bounds certificates, which is what the resumable-strategy shape was for: each field is first-order, so each is certified separately with the ordinary combinators. `answer` is synthesised by the `bounds` tactic. The tactic fails on `isDone` — it tries `Function.uncurry List.isEmpty` when a disjunction has an `isEmpty` application as an argument — so that one is built by hand; worth a look when the tactic is next touched. Two things worth noting for later readers: * Field access goes through `Activation.toProd`, certified by `Bounds.recode`, so accessors are ordinary fst/snd chains. The chains are positional and easy to miscount; `mkActivation` wraps the seven-fold fan-out so the assembling direction is named rather than positional. * `enter` is the only place the graph is consulted, so certificates for vertex equality and for the edge relation are this example's only hypotheses. They depend on how the graph is represented, which `reach` deliberately leaves open. Still to do: the D, F, B and N obligations and the final assembly into Bounds.depthRec. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/Complexity/Examples/Reach.lean | 129 ++++++++++++++++++ 1 file changed, 129 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean index ec68c6af49..182520ae54 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean @@ -7,6 +7,7 @@ Authors: Christian Reitwiessner module public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.DepthRec +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsTactic /-! # Reachability by double recursion @@ -237,6 +238,134 @@ lemma heval (E : V → V → Bool) (verts : List V) (k : Level) (a b : V) : rw [he] simpa [reach] using scan E verts ks u (fun x y => ih x y) a b verts +/-! ## Certificates for the schema's fields + +Each field is a first-order function, which is the point of the `RecSchema` shape: they can be +certified separately with the ordinary combinators. The structure's fields are reached through +`Activation.toProd`, which `Bounds.recode` certifies for free. -/ + +/-- Viewing an activation as its underlying tuple: a no-op on encodings. -/ +def toProdBounds : Bounds (Activation.toProd (V := V)) := Bounds.recode (fun _ => rfl) + +/-- Building an activation from its components: also a no-op on encodings. -/ +def ofProdBounds : Bounds (Activation.ofProd (V := V)) := Bounds.recode (fun _ => rfl) + +/-- `level` -/ +def levelBounds : Bounds (fun s : Activation V => s.level) := + Bounds.comp' _ Bounds.fst toProdBounds + +/-- `source` -/ +def sourceBounds : Bounds (fun s : Activation V => s.source) := + Bounds.comp' _ (Bounds.comp' _ Bounds.fst Bounds.snd) toProdBounds + +/-- `target` -/ +def targetBounds : Bounds (fun s : Activation V => s.target) := + Bounds.comp' _ (Bounds.comp' _ Bounds.fst (Bounds.comp' _ Bounds.snd Bounds.snd)) toProdBounds + +/-- `remaining` -/ +def remainingBounds : Bounds (fun s : Activation V => s.remaining) := + Bounds.comp' _ (Bounds.comp' _ Bounds.fst + (Bounds.comp' _ Bounds.snd (Bounds.comp' _ Bounds.snd Bounds.snd))) toProdBounds + +/-- `finished` -/ +def finishedBounds : Bounds (fun s : Activation V => s.finished) := + Bounds.comp' _ (Bounds.comp' _ Bounds.fst (Bounds.comp' _ Bounds.snd + (Bounds.comp' _ Bounds.snd (Bounds.comp' _ Bounds.snd Bounds.snd)))) toProdBounds + +/-- `result` -/ +def resultBounds : Bounds (fun s : Activation V => s.result) := + Bounds.comp' _ (Bounds.comp' _ Bounds.fst (Bounds.comp' _ Bounds.snd (Bounds.comp' _ Bounds.snd + (Bounds.comp' _ Bounds.snd (Bounds.comp' _ Bounds.snd Bounds.snd))))) toProdBounds + +/-- `awaitingRight` -/ +def awaitingRightBounds : Bounds (fun s : Activation V => s.awaitingRight) := + Bounds.comp' _ (Bounds.comp' _ Bounds.snd (Bounds.comp' _ Bounds.snd (Bounds.comp' _ Bounds.snd + (Bounds.comp' _ Bounds.snd (Bounds.comp' _ Bounds.snd Bounds.snd))))) toProdBounds + +attribute [bounds] levelBounds sourceBounds targetBounds remainingBounds finishedBounds + resultBounds awaitingRightBounds ofProdBounds + +/-- Boolean disjunction, on the finite type `Bool × Bool`. -/ +def orBounds : Bounds (Function.uncurry (· || · : Bool → Bool → Bool)) := Bounds.ofFintype _ + +attribute [bounds] orBounds + +/-- `answer` is a single field access. -/ +def answerBounds : Bounds (answer (V := V)) := by bounds + +/-- `isDone` is two `isEmpty` tests and two disjunctions. -/ +def isDoneBounds : Bounds (isDone (V := V)) := + Bounds.comp' _ orBounds + (Bounds.pair finishedBounds + (Bounds.comp' _ orBounds + (Bounds.pair (Bounds.comp' _ Bounds.isEmpty remainingBounds) + (Bounds.comp' _ Bounds.isEmpty levelBounds)))) + (by funext s; simp [isDone, Bool.or_assoc]) + +/-- **Assembling an activation** from certificates for its seven components. `Activation.ofProd` +is a no-op on encodings, so this costs no more than the fan-out that builds the tuple. -/ +def mkActivation {α : Type} [DataEncode α] {fLevel : α → Level} {fSource fTarget : α → V} + {fRemaining : α → List V} {fFinished fResult fAwait : α → Bool} + (hLevel : Bounds fLevel) (hSource : Bounds fSource) (hTarget : Bounds fTarget) + (hRemaining : Bounds fRemaining) (hFinished : Bounds fFinished) (hResult : Bounds fResult) + (hAwait : Bounds fAwait) : + Bounds (fun a => ({ + level := fLevel a, source := fSource a, target := fTarget a, + remaining := fRemaining a, finished := fFinished a, result := fResult a, + awaitingRight := fAwait a } : Activation V)) := + Bounds.comp' _ ofProdBounds + (Bounds.pair hLevel (Bounds.pair hSource (Bounds.pair hTarget (Bounds.pair hRemaining + (Bounds.pair hFinished (Bounds.pair hResult hAwait)))))) + +/-- `ask`: drop one level, and pick the half determined by `awaitingRight`. -/ +def askBounds : Bounds (ask (V := V)) := + Bounds.pair' _ (Bounds.comp' _ Bounds.tail levelBounds) + (Bounds.pair' _ + (Bounds.ite awaitingRightBounds + (Bounds.comp' _ (Bounds.headD default) remainingBounds) sourceBounds) + (Bounds.ite awaitingRightBounds targetBounds + (Bounds.comp' _ (Bounds.headD default) remainingBounds))) + +/-- `resume`, as a function of the pair `(activation, sub-answer)`. -/ +def resumeBounds : Bounds (Function.uncurry (resume (V := V))) := + Bounds.ite Bounds.snd + (Bounds.ite (Bounds.comp' _ awaitingRightBounds Bounds.fst) + (mkActivation (Bounds.comp' _ levelBounds Bounds.fst) + (Bounds.comp' _ sourceBounds Bounds.fst) (Bounds.comp' _ targetBounds Bounds.fst) + (Bounds.comp' _ remainingBounds Bounds.fst) (Bounds.const true) (Bounds.const true) + (Bounds.const false)) + (mkActivation (Bounds.comp' _ levelBounds Bounds.fst) + (Bounds.comp' _ sourceBounds Bounds.fst) (Bounds.comp' _ targetBounds Bounds.fst) + (Bounds.comp' _ remainingBounds Bounds.fst) + (Bounds.comp' _ finishedBounds Bounds.fst) (Bounds.comp' _ resultBounds Bounds.fst) + (Bounds.const true))) + (mkActivation (Bounds.comp' _ levelBounds Bounds.fst) + (Bounds.comp' _ sourceBounds Bounds.fst) (Bounds.comp' _ targetBounds Bounds.fst) + (Bounds.comp' _ Bounds.tail (Bounds.comp' _ remainingBounds Bounds.fst)) + (Bounds.const false) (Bounds.const false) (Bounds.const false)) + +/-- The two endpoints of a question. -/ +def endpointsBounds : Bounds (fun q : Question V => (q.2.1, q.2.2)) := + Bounds.pair (Bounds.comp' _ Bounds.fst Bounds.snd) (Bounds.comp' _ Bounds.snd Bounds.snd) + +/-- `enter`. The level-zero branch is the only place the graph is consulted, so the certificates +for vertex equality and for the edge relation are this example's only hypotheses — they depend on +how the graph is represented, which `reach` deliberately does not fix. -/ +def enterBounds (E : V → V → Bool) (verts : List V) + (hEq : Bounds (Function.uncurry (· == · : V → V → Bool))) + (hE : Bounds (Function.uncurry E)) : + Bounds (enter E verts) := + (Bounds.ite (Bounds.comp' _ Bounds.isEmpty Bounds.fst) + (mkActivation (Bounds.const ([] : Level)) (Bounds.comp' _ Bounds.fst Bounds.snd) + (Bounds.comp' _ Bounds.snd Bounds.snd) (Bounds.const ([] : List V)) (Bounds.const true) + (Bounds.comp' _ orBounds + (Bounds.pair (Bounds.comp' _ hEq endpointsBounds) (Bounds.comp' _ hE endpointsBounds))) + (Bounds.const false)) + (mkActivation Bounds.fst (Bounds.comp' _ Bounds.fst Bounds.snd) + (Bounds.comp' _ Bounds.snd Bounds.snd) (Bounds.const verts) (Bounds.const false) + (Bounds.const false) (Bounds.const false))).congr + (by funext q; simp [enter, scanning, Function.uncurry]) + end Reach end MultiTapeTM From c5ca7eab53c354cfca2c84e6a5a12906aef43484 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 1 Sep 2026 18:08:19 +0000 Subject: [PATCH 8/8] feat(Complexity): the D obligation and the frame invariant for reach MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `level_enter_le` discharges depthRec's D: the opening level is bounded by the input size. `FrameOK` is the schema-level invariant that `frame_inv` transfers to every reachable machine state — the level only shrinks, the midpoint list is always a suffix of `verts`, and both endpoints come from the original question or from `verts`. It is proved closed under entering a sub-question and under resumption, which is all `frame_inv` asks for; no reasoning about `mstep^[j]` appears. Stating `enter`'s fields as three separate equations (enter_level, enter_remaining, enter_endpoints) rather than casing on the level test inside each proof is what made these go through cleanly. Still to do: turning FrameOK into the numeric F, the step measure for N, and the final assembly. Co-Authored-By: Claude Opus 5 (1M context) --- .../MultiTape/Complexity/Examples/Reach.lean | 121 ++++++++++++++++++ 1 file changed, 121 insertions(+) diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean index 182520ae54..a1259c430e 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean @@ -366,6 +366,127 @@ def enterBounds (E : V → V → Bool) (verts : List V) (Bounds.const false) (Bounds.const false))).congr (by funext q; simp [enter, scanning, Function.uncurry]) +/-! ## The resource obligations -/ + +/-- Reachability as a function of the whole question — the shape `depthRec` certifies. -/ +def reachOf (E : V → V → Bool) (verts : List V) (q : Question V) : Bool := + reach E verts q.1 q.2.1 q.2.2 + +omit [DataEncode V] in +/-- `heval`, packaged for `depthRec`. -/ +lemma heval' (E : V → V → Bool) (verts : List V) (q : Question V) : + Eval (schema E verts) q (reachOf E verts q) := heval E verts q.1 q.2.1 q.2.2 + +/-- **`D`: the opening level is bounded by the input size.** -/ +lemma level_enter_le (E : V → V → Bool) (verts : List V) (q : Question V) : + (schema E verts).level ((schema E verts).enter q) ≤ (DataEncode.encode q).size := by + have h2 : (DataEncode.encode q).size + = (DataEncode.encode q.1).size + (DataEncode.encode q.2).size + 2 := + DataEncode.size_pair _ _ + simp only [schema, enter] + cases hc : q.1.isEmpty with + | true => simp + | false => + simp only [Bool.cond_false, scanning] + have := DataEncode.length_le_size q.1 + omega + +/-- **The frame invariant.** The level only ever shrinks, the midpoint list is always a suffix of +`verts`, and the two endpoints are drawn from the original question or from `verts`. -/ +def FrameOK (verts : List V) (q : Question V) (s : Activation V) : Prop := + s.level.length ≤ q.1.length ∧ (∃ n, s.remaining = verts.drop n) ∧ + s.source ∈ q.2.1 :: q.2.2 :: default :: verts ∧ + s.target ∈ q.2.1 :: q.2.2 :: default :: verts + +omit [DataEncode V] [DecidableEq V] in +/-- The head of a suffix of `verts` is one of the listed vertices. -/ +lemma head_mem {verts r : List V} (h : ∃ n, r = verts.drop n) (q : Question V) : + r.head?.getD default ∈ q.2.1 :: q.2.2 :: default :: verts := by + obtain ⟨n, rfl⟩ := h + cases hd : (verts.drop n).head? with + | none => simp + | some v => + have hv : v ∈ verts := List.mem_of_mem_drop (List.mem_of_head? hd) + simp [hv] + +omit [DataEncode V] in +/-- Both endpoints of a sub-question stay within the allowed set. -/ +lemma ask_endpoints_mem (E : V → V → Bool) (verts : List V) (q : Question V) (s : Activation V) + (hs : FrameOK verts q s) : + ((schema E verts).ask s).2.1 ∈ q.2.1 :: q.2.2 :: default :: verts ∧ + ((schema E verts).ask s).2.2 ∈ q.2.1 :: q.2.2 :: default :: verts := by + obtain ⟨-, hrem, hsrc, htgt⟩ := hs + have hhead := head_mem hrem q + simp only [schema, ask] + cases hw : s.awaitingRight + · exact ⟨by simpa using hsrc, by simpa using hhead⟩ + · exact ⟨by simpa using hhead, by simpa using htgt⟩ + +omit [DataEncode V] [Inhabited V] in +/-- The level of a freshly entered activation. -/ +lemma enter_level (E : V → V → Bool) (verts : List V) (p : Question V) : + (enter E verts p).level = cond p.1.isEmpty [] p.1 := by + cases hc : p.1.isEmpty <;> simp [enter, scanning, hc] + +omit [DataEncode V] [Inhabited V] in +/-- Its midpoint list. -/ +lemma enter_remaining (E : V → V → Bool) (verts : List V) (p : Question V) : + (enter E verts p).remaining = cond p.1.isEmpty [] verts := by + cases hc : p.1.isEmpty <;> simp [enter, scanning, hc] + +omit [DataEncode V] [Inhabited V] in +/-- Its endpoints, which are the question's. -/ +lemma enter_endpoints (E : V → V → Bool) (verts : List V) (p : Question V) : + (enter E verts p).source = p.2.1 ∧ (enter E verts p).target = p.2.2 := by + cases hc : p.1.isEmpty <;> + exact ⟨by simp [enter, scanning, hc], by simp [enter, scanning, hc]⟩ + +omit [DataEncode V] in +/-- The invariant holds at the opening activation. -/ +lemma frameOK_enter (E : V → V → Bool) (verts : List V) (q : Question V) : + FrameOK verts q ((schema E verts).enter q) := by + obtain ⟨he1, he2⟩ := enter_endpoints E verts q + simp only [schema] + refine ⟨?_, ?_, by simp [he1], by simp [he2]⟩ + · rw [enter_level]; cases q.1.isEmpty <;> simp + · rw [enter_remaining]; cases q.1.isEmpty + · exact ⟨0, by simp⟩ + · exact ⟨verts.length, by simp⟩ + +omit [DataEncode V] in +/-- The invariant survives entering a sub-question. -/ +lemma frameOK_ask (E : V → V → Bool) (verts : List V) (q : Question V) (s : Activation V) + (hs : FrameOK verts q s) : + FrameOK verts q ((schema E verts).enter ((schema E verts).ask s)) := by + obtain ⟨hsrc', htgt'⟩ := ask_endpoints_mem E verts q s hs + obtain ⟨hlen, -, -, -⟩ := hs + obtain ⟨he1, he2⟩ := enter_endpoints E verts ((schema E verts).ask s) + simp only [schema] at hsrc' htgt' he1 he2 ⊢ + have hlen' : (ask s).1.length ≤ q.1.length := by + have : (ask s).1 = s.level.tail := rfl + rw [this] + calc s.level.tail.length ≤ s.level.length := by simp + _ ≤ q.1.length := hlen + refine ⟨?_, ?_, by rw [he1]; exact hsrc', by rw [he2]; exact htgt'⟩ + · rw [enter_level]; cases (ask s).1.isEmpty <;> simp [hlen'] + · rw [enter_remaining]; cases (ask s).1.isEmpty + · exact ⟨0, by simp⟩ + · exact ⟨verts.length, by simp⟩ + +omit [DataEncode V] in +/-- The invariant survives resumption. -/ +lemma frameOK_resume (E : V → V → Bool) (verts : List V) (q : Question V) (s : Activation V) + (ans : Bool) (hs : FrameOK verts q s) : + FrameOK verts q ((schema E verts).resume s ans) := by + obtain ⟨hlen, ⟨n, hn⟩, hsrc, htgt⟩ := hs + cases ans <;> cases hw : s.awaitingRight <;> + refine ⟨by simpa [schema, resume, hw] using hlen, ?_, + by simpa [schema, resume, hw] using hsrc, by simpa [schema, resume, hw] using htgt⟩ + · exact ⟨n + 1, by simp [schema, resume, hw, hn, List.tail_drop]⟩ + · exact ⟨n + 1, by simp [schema, resume, hw, hn, List.tail_drop]⟩ + · exact ⟨n, by simp [schema, resume, hw, hn]⟩ + · exact ⟨n, by simp [schema, resume, hw, hn]⟩ + end Reach end MultiTapeTM