diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean new file mode 100644 index 0000000000..4d8b6b46d4 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity.lean @@ -0,0 +1,112 @@ +/- +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.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.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 +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.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 +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 +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 18 statements are `sorry`-ed. They fall +into exactly two groups: + +* **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 +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. +* `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 + +| 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/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: + +| 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 + +* [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..a22d95dd0e --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Bounds.lean @@ -0,0 +1,148 @@ +/- +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 +public meta import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsAttr + +/-! +# 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 := 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, 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, 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, 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 : ℕ → ℕ) + (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 _) + +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 + (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/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/Data.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean new file mode 100644 index 0000000000..464ec3e7c2 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Data.lean @@ -0,0 +1,168 @@ +/- +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 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/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 new file mode 100644 index 0000000000..179deed6b1 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Encoding.lean @@ -0,0 +1,390 @@ +/- +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 +public import Mathlib.Data.Sign.Defs + +/-! +# 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 + +/-- **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 + 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 natBit_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, natBit_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, natBit_eq_two_mul_add, List.length_cons, pow_succ] + cases b <;> simp <;> omega + +/-- Multiplying adds at most the two bit lengths. -/ +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 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) + +/-- `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 + +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 +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_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 + 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/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/InputCursor.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/InputCursor.lean new file mode 100644 index 0000000000..0765eb978c --- /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) + +/-- 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.id + (Bounds.pair + (Bounds.cons (Bounds.comp (Bounds.headD d) + Bounds.snd) + Bounds.fst) + (Bounds.comp Bounds.tail + Bounds.snd))) + +/-- Moving left. -/ +def cursorLBounds (d : α) : Bounds (cursorL d) := + (Bounds.ite + (Bounds.comp Bounds.isEmpty Bounds.fst) + Bounds.id + (Bounds.pair + (Bounds.comp Bounds.tail Bounds.fst) + (Bounds.cons (Bounds.comp (Bounds.headD d) + Bounds.fst) + Bounds.snd))) + +/-! ### 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/ListIndex.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean new file mode 100644 index 0000000000..f0decd1d01 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListIndex.lean @@ -0,0 +1,218 @@ +/- +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 -/ + +/-- 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 (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 + = (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 := + foldFun_size_le (fun n => n + 8) 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..b277790b92 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListMap.lean @@ -0,0 +1,133 @@ +/- +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 => ?_) + · nlinarith [sq_nonneg n] + · 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.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)) + +end ListMap + +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..4f0dc33ff7 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/ListUpdate.lean @@ -0,0 +1,288 @@ +/- +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 := + foldFun_size_le (fun n => 2 * n + 6) 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.snd) rfl + +/-- Projecting the output list out of the accumulator is the same two projections. -/ +def outBounds [DataEncode α] : Bounds (updateOut (α := α)) := + listBounds + +/-- **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/Lookup.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean new file mode 100644 index 0000000000..3aa38167f8 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Lookup.lean @@ -0,0 +1,125 @@ +/- +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 +/-! ### 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 + let hi : Bounds (lookupInit : Table K V × K → K × Option V) := + (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.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/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..7af7096afa --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/MachineDesc.lean @@ -0,0 +1,117 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.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 — 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: +`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 UntypedTable := 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)) : 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)) + +/-! ### 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/NatArith.lean b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean new file mode 100644 index 0000000000..d01ca150ae --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatArith.lean @@ -0,0 +1,327 @@ +/- +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, natBit_eq_two_mul_add] + | cons b bs ih => + have h := ih (c && b) + simp only [incSpec, List.cons_append, natOfBits_cons, natBit_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 := + foldFun_size_le (fun n => 4 * n + 8) 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 => ?_) + · nlinarith [sq_nonneg n] + · 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, 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, + natBit_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 := + foldFun_size_le (fun n => 4 * n + 8) 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 => ?_) + · nlinarith [sq_nonneg n] + · 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..0a374150d1 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/NatMul.lean @@ -0,0 +1,149 @@ +/- +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, natBit_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 (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 := 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] + 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 := + foldFun_size_le (fun n => 2 * n) 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 => ?_) + · nlinarith [sq_nonneg n] + · omega + +end NatMul + +end MultiTapeTM + +end Turing 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..a1259c430e --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Reach.lean @@ -0,0 +1,494 @@ +/- +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 +public import Cslib.Computability.Machines.Turing.MultiTape.Complexity.BoundsTactic + +/-! +# 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 + +/-! ## 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]) + +/-! ## 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 + +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..322537d0c9 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SimConfig.lean @@ -0,0 +1,314 @@ +/- +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 + +lemma moveCursor_zero {α : Type} (blank : α) (c : Cursor α) : + moveCursor blank SignType.zero c = c := rfl + +lemma moveCursor_neg {α : Type} (blank : α) (c : Cursor α) : + moveCursor blank SignType.neg c = cursorL blank c := rfl + +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] + +/-- 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 +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/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 new file mode 100644 index 0000000000..03bc377d6e --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/SpaceBound.lean @@ -0,0 +1,128 @@ +/- +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 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)) + ⊆ (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 natAbs_sub_add_one_le_card_image + (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/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 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..04b06c37a0 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Tape.lean @@ -0,0 +1,217 @@ +/- +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. + +## Where this leads + +`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 + +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) + +/-- 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)) + +/-- 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)) + +/-! ### 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 i) + let sym : Bounds (fun p : Instr Q S × (Q × Tape S) => p.1.2.1) := + 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.snd) i + let tp : Bounds (fun p : Instr Q S × (Q × Tape S) => p.2.2) := + (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)) + (Bounds.pair st + (Bounds.ite dir + (Bounds.comp (moveRBounds blank) written) + (Bounds.comp (moveLBounds blank) written))) + +/-! ### 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) + let instr : Bounds (fun c : Q × Tape S => tr (c.1, read blank c.2)) := + (Bounds.comp (Bounds.ofFintype tr) + (Bounds.pair Bounds.fst rd)) + (Bounds.comp (applyInstrBounds blank) + (Bounds.pair instr Bounds.id)) + +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..6d10a16175 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeStep.lean @@ -0,0 +1,174 @@ +/- +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 + +lemma applyAction_none_zero (blank : S) (t : Tape S) : + applyAction blank (none, SignType.zero) t = t := rfl + +lemma applyAction_none_neg (blank : S) (t : Tape S) : + applyAction blank (none, SignType.neg) t = moveL blank t := rfl + +lemma applyAction_none_pos (blank : S) (t : Tape S) : + applyAction blank (none, SignType.pos) t = moveR blank t := rfl + +lemma applyAction_some_zero (blank : S) (s : S) (t : Tape S) : + applyAction blank (some s, SignType.zero) t = write (t, s) := rfl + +lemma applyAction_some_neg (blank : S) (s : S) (t : Tape S) : + applyAction blank (some s, SignType.neg) t = moveL blank (write (t, s)) := rfl + +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.of_applyAction (blank : S) (a : Option S × SignType) {t : Tape S} {lo p hi : ℤ} + (h : Extent t lo p hi) : + ∃ 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 + 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, + by rw [signCast_neg]; omega, Or.inl rfl⟩ + rw [hn, applyAction_none_neg] + exact Extent.of_moveL blank h + | pos => + 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.of_moveR blank h + | some s => + 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, + 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, + by rw [signCast_neg]; omega, by omega⟩ + rw [hn, applyAction_some_neg] + exact Extent.of_moveL blank hw + | pos => + 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 + +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..3580230644 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/TapeView.lean @@ -0,0 +1,202 @@ +/- +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`. 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 + +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.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 : (moveR blank t).1.length = t.1.length + 1 := by simp [moveR] + omega + · cases hr : t.2 with + | nil => + 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 : (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.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 : (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 : (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 : (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.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 : (write ((t, s) : Tape S × S)).1.length + = t.1.length := by simp [write] + omega + · cases hr : t.2 with + | nil => + 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 : (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 + +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..85191d4795 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Examples/Universal.lean @@ -0,0 +1,368 @@ +/- +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.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 + let cfg : Bounds (fun c : UCfg Q S => c.2) := + Bounds.snd + let st : Bounds (fun c : UCfg Q S => c.2.1) := + (Bounds.comp Bounds.fst cfg) + let tp : Bounds (fun c : UCfg Q S => c.2.2) := + (Bounds.comp Bounds.snd cfg) + let rd : Bounds (fun c : UCfg Q S => read blank c.2.2) := + (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)) + 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) + (Bounds.pair tbl (Bounds.comp (applyInstrBounds blank) (Bounds.pair instr cfg))) + +/-! ### 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 + (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.snd) + ((Bounds.comp + (Bounds.ite (uHaltBounds halting) Bounds.id + (uStepBounds blank dflt)) + 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 + 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 + +/-- 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 + (Bounds.cons (Bounds.const (() : Unit)) + Bounds.fst) + (Bounds.comp (uStepBounds blank dflt) + 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) + +/-- 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) + +/-- **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..eac3a2da9a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Fold.lean @@ -0,0 +1,141 @@ +/- +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] + +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.** + +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 := 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. -/ +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..43f4835822 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Complexity/Primitives.lean @@ -0,0 +1,321 @@ +/- +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 _ + +/-- **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 + 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 + +/-- **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) : + 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 + +/-- **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 + +/-- 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