From 94447dd807b5658970985b0c2b989179ccaf4bc6 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 10 Jun 2026 18:27:43 +0200 Subject: [PATCH 01/22] RTM v4, in progress. --- Cslib/Computability/Machines/RTM/Data.lean | 100 ++ .../Machines/RTM/DataEncode.lean | 93 ++ Cslib/Computability/Machines/RTM/PB.lean | 265 ++++ Cslib/Computability/Machines/RTM/Prog.lean | 201 +++ .../Machines/RTM/TMSimulator.lean | 1089 +++++++++++++++++ Cslib/Computability/Machines/RTM/Tools.lean | 152 +++ 6 files changed, 1900 insertions(+) create mode 100644 Cslib/Computability/Machines/RTM/Data.lean create mode 100644 Cslib/Computability/Machines/RTM/DataEncode.lean create mode 100644 Cslib/Computability/Machines/RTM/PB.lean create mode 100644 Cslib/Computability/Machines/RTM/Prog.lean create mode 100644 Cslib/Computability/Machines/RTM/TMSimulator.lean create mode 100644 Cslib/Computability/Machines/RTM/Tools.lean diff --git a/Cslib/Computability/Machines/RTM/Data.lean b/Cslib/Computability/Machines/RTM/Data.lean new file mode 100644 index 000000000..3f482b203 --- /dev/null +++ b/Cslib/Computability/Machines/RTM/Data.lean @@ -0,0 +1,100 @@ +/- +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.Data.Part + + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +/-- Rose-tree data structure, it allows us to encode most of Lean's data structures in a +"natural" manner -/ +inductive Data where + | l : List Data → Data +deriving Repr + +mutual + def Data.decEq : ∀ (a b : Data), Decidable (a = b) + | .l xs, .l ys => + match Data.listDecEq xs ys with + | isTrue h => isTrue (congrArg Data.l h) + | isFalse h => isFalse fun heq => h (Data.l.inj heq) + def Data.listDecEq : ∀ (xs ys : List Data), Decidable (xs = ys) + | [], [] => isTrue rfl + | [], _ :: _ => isFalse (by simp) + | _ :: _, [] => isFalse (by simp) + | x :: xs, y :: ys => + match Data.decEq x y, Data.listDecEq xs ys with + | isTrue hxy, isTrue hxys => isTrue (congrArg₂ List.cons hxy hxys) + | isFalse hxy, _ => isFalse fun h => hxy (List.cons.inj h).1 + | _, isFalse hxys => isFalse fun h => hxys (List.cons.inj h).2 +end + +instance : DecidableEq Data := Data.decEq +instance : BEq Data := inferInstance +instance : LawfulBEq Data := inferInstance + +abbrev Data.empty := Data.l [] + + +@[scoped grind =] +def Data.asList + | Data.l xs => xs + +@[simp] +lemma Data.asList_empty : Data.empty.asList = [] := by rfl + +@[simp, scoped grind =] +lemma Data.asList_l (d : Data) : Data.l d.asList = d := by simp [Data.asList]; grind + +@[simp, scoped grind =] +lemma Data.l_asList (xs : List Data) : (Data.l xs).asList = xs := by simp [Data.asList] + +/-- The encoding length of `d`, relevant for complexity. +This is the encoded size assuming an encoding into parenthesized expressions. -/ +def Data.size : Data → ℕ + | Data.l xs => 2 + (xs.map Data.size |>.sum) + +@[simp, scoped grind =] +lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size] + +@[simp, scoped grind =] +lemma Data.cons_size {h : Data} {t : List Data} : + (Data.l (h :: t)).size = h.size + (Data.l t).size := by + simp [Data.size] + grind + +/-- Recursion principle for `Data`. -/ +@[elab_as_elim] +def Data.recL {motive : Data → Sort*} + (nil : motive (Data.l [])) + (cons : ∀ (x : Data) (xs : List Data), + motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) : + ∀ d, motive d + | .l [] => nil + | .l (x :: xs) => + cons x xs (Data.recL nil cons x) (Data.recL nil cons (.l xs)) + +/-- Induction principle for `Data`, the `Prop`-valued companion to `Data.recL`. -/ +@[elab_as_elim] +theorem Data.inductionL {motive : Data → Prop} + (nil : motive (Data.l [])) + (cons : ∀ (x : Data) (xs : List Data), + motive x → motive (Data.l xs) → motive (Data.l (x :: xs))) + (d : Data) : motive d := + Data.recL nil cons d + +abbrev TapeIndex := ℕ + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/RTM/DataEncode.lean b/Cslib/Computability/Machines/RTM/DataEncode.lean new file mode 100644 index 000000000..ed731e542 --- /dev/null +++ b/Cslib/Computability/Machines/RTM/DataEncode.lean @@ -0,0 +1,93 @@ +/- +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.RTM.Data +public import Mathlib.Data.Nat.Bits +public import Mathlib.Data.List.Basic + + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +/-- Encoding of types into `Data`. -/ +class DataEncode (α : Type) where + encode : α → Data + h_inj : encode.Injective + +instance : DataEncode Bool where + encode b := if b then Data.l [ Data.l [] ] else Data.l [] + h_inj := by intros a b h_eq; grind + +instance (α : Type) [DataEncode α] : DataEncode (List α) where + encode xs := Data.l (xs.map DataEncode.encode) + h_inj := by + intro a b h + have h' : a.map (DataEncode.encode : α → Data) = b.map DataEncode.encode := + Data.l.inj h + exact List.map_injective_iff.mpr DataEncode.h_inj h' + +@[simp, scoped grind =] +lemma DataEncode_list_nil {α : Type} [DataEncode α] : + DataEncode.encode ([] : List α) = Data.l [] := by + simp [DataEncode.encode] + +@[simp, scoped grind =] +lemma DataEncode_list_eq_nil_iff_nil {α : Type} [DataEncode α] (xs : List α) : + DataEncode.encode xs = Data.empty ↔ xs = [] := by + simp [DataEncode.encode] + +@[simp, scoped grind =] +lemma DataEncode_list_tail {α : Type} [DataEncode α] (xs : List α) : + (DataEncode.encode xs).asList.tail = (DataEncode.encode xs.tail).asList := by + simp [DataEncode.encode] + +instance (α : Type) [DataEncode α] : DataEncode (Option α) where + encode := fun + | none => Data.l [] + | some x => Data.l [DataEncode.encode x] + h_inj := by + intro a b h + cases a <;> cases b <;> simp_all + exact DataEncode.h_inj h + +@[simp] +lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) : + (DataEncode.encode x == Data.empty) = x.isNone := by + cases x <;> simp [DataEncode.encode, Data.empty] + +instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) where + encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b] + h_inj := by + intro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h + simp at h + exact Prod.mk.injEq .. |>.mpr ⟨DataEncode.h_inj h.1, DataEncode.h_inj h.2⟩ + +lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) : + DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by + simp [DataEncode.encode] + +instance : DataEncode ℕ where + encode x := DataEncode.encode (Nat.bits x) + h_inj := by + intro a b h + have hb : a.bits = b.bits := DataEncode.h_inj h + -- Reconstruct a from a.bits via binaryRec. + have hrec : ∀ n : ℕ, n.bits.foldr (fun b acc => Nat.bit b acc) 0 = n := by + intro n + induction n using Nat.binaryRec' with + | zero => simp + | bit b n hn ih => rw [Nat.bits_append_bit n b hn]; simp [ih] + have := congrArg (List.foldr (fun b acc => Nat.bit b acc) 0) hb + simpa [hrec] using this + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean new file mode 100644 index 000000000..5e2c5afac --- /dev/null +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -0,0 +1,265 @@ +/- +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.RTM.Prog +public import Cslib.Computability.Machines.RTM.DataEncode + +/-! # RoseTreeMachine — PB (program builder) + +A thin builder layer over the de-Bruijn-levelled `Prog`. +-/ + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +/-- A program builder: given the current binder depth (the size of `env` at the point of +insertion), produce a `Prog`. -/ +abbrev PB := ℕ → Prog + +namespace PB + +def var (i : ℕ) : PB := fun _ => .var i +def empty : PB := fun _ => .empty +def cons (h t : PB) : PB := fun n => .cons (h n) (t n) +def fn (body : PB → PB) : PB := fun n => .fn (body (var n) (n + 1)) +def app (f a : PB) : PB := fun n => .app (f n) (a n) +def elim (v em : PB) (cs : PB → PB → PB) : PB := fun n => + .elim (v n) (em n) (.fn (.fn (cs (var n) (var (n + 1)) (n + 2)))) +def ifEq (x y then_ else_ : PB) : PB := fun n => .ifEq (x n) (y n) (then_ n) (else_ n) +def while_ (init : PB) (body : PB → PB) : PB := fun n => + .while_ (init n) (.fn (body (var n) (n + 1))) + +/-- Close a builder into a concrete `Prog`. -/ +def build (p : PB) : Prog := p 0 + + +variable {env : List Value} + +/-! ### Resource-erased (`ProgSem`-based) semantics for program builders + +`PB.computes env impl out` says that, under any outer extension `ext`, the builder unfolded at +the current variable depth `(env ++ ext).length` evaluates (via `ProgSem`) to the first-order +value `out` for *some* time and space. The first-order environment `env : List Data` is lifted +into the value space via `Value.data`. The `∀ ext` quantifier lets a builder be plugged into a +binder body where the environment later grows. -/ + +/-- Resource-erased relational semantics of a program builder. -/ +def Computes (env : List Value) (impl : PB) (out : Value) : Prop := + ∀ ext : List Value, + ∃ t s, ProgSem (env ++ ext) (impl (env.length + ext.length)) + out t s + +/-- The basic per-env consequence, instantiating `ext := []`. -/ +lemma Computes.here {impl : PB} {out : Value} + (h : Computes env impl out) : + ∃ t s, ProgSem env (impl env.length) out t s := by + simpa using h [] + +/-- `Computes` is preserved when the environment is extended with extra trailing bindings: +the trailing bindings are invisible to a program that only reaches into `env`. -/ +lemma Computes.extend {impl : PB} {out : Value} (more : List Value) + (h : Computes env impl out) : + Computes (env ++ more) impl out := by + intro ext + simpa [List.append_assoc, List.length_append, Nat.add_assoc] using h (more ++ ext) + +/-- Variant of `Computes.extend` matching the left-associated environment shape `env ++ a ++ b` +produced by the eliminator combinators. -/ +lemma Computes.extend_append {impl : PB} {out : Value} (a b : List Value) + (h : Computes env impl out) : + Computes (env ++ a ++ b) impl out := by + rw [List.append_assoc]; exact h.extend (a ++ b) + +/-- Analogon of `Computes`, but as a statement of the pre-encoded value. +This allows statements that `PB`s compute functions on lean datatypes. -/ +def ComputesEnc {α : Type} [DataEncode α] (env : List Value) (impl : PB) (x : α) := + Computes env impl (.data (DataEncode.encode x)) + +/-- Var-lookup: `PB.var i` reads the `i`-th entry of the environment. -/ +@[simp] +lemma var_computes {i : ℕ} (h : i < env.length) : + Computes env (PB.var i) env[i] := by + intro ext + simp only [PB.var] + have hval : (env ++ ext)[i]?.getD Value.empty = env[i] := by grind + exact ⟨_, _, hval ▸ ProgSem.var⟩ + +/-- A freshly-bound first argument: the variable at level `env.length + ext.length` reads the +first of the trailing bindings `v :: binds`. -/ +lemma var_computes_fresh {v : Value} (ext binds : List Value) : + Computes (env ++ ext ++ (v :: binds)) (PB.var (env.length + ext.length)) v := by + have hlt : env.length + ext.length < (env ++ ext ++ (v :: binds)).length := by + simp [List.length_append] + have hget : (env ++ ext ++ (v :: binds))[env.length + ext.length]'hlt = v := by + rw [List.getElem_append_right (by simp [List.length_append])] + simp [List.length_append] + simpa [hget] using var_computes (env := env ++ ext ++ (v :: binds)) hlt + +@[simp] +lemma empty_computes : Computes env empty (.data (.l [])) := by + intro ext + exact ⟨2, 2, ProgSem.empty⟩ + +@[simp] +lemma cons_computes {h t : PB} {dh dt : Data} + (hh : Computes env h (.data dh)) (ht : Computes env t (.data dt)) : + Computes env (PB.cons h t) (.data (.l (dh :: dt.asList))) := by + intro ext + obtain ⟨th, sh, hh'⟩ := hh ext + obtain ⟨tt, st, ht'⟩ := ht ext + exact ⟨_, _, ProgSem.cons hh' ht'⟩ + +/-- A `PB.var` at the absolute level of the `j`-th freshly-bound variable reads `binds[j]`. -/ +@[simp] +lemma var_computesFun {binds : List Value} {j : ℕ} (ext : List Value) : + ∃ t s, ProgSem (env ++ ext ++ binds) + (.var (env.length + ext.length + j)) (binds[j]?.getD .empty) t s := by + have hval : (env ++ ext ++ binds)[env.length + ext.length + j]?.getD Value.empty + = binds[j]?.getD .empty := by + have e1 : env.length + ext.length + j = (env ++ ext).length + j := by + simp [List.length_append] + rw [e1, List.getElem?_append_right (Nat.le_add_right _ _), Nat.add_sub_cancel_left] + exact ⟨_, _, hval ▸ ProgSem.var⟩ + +/-- The code in `body` computes a function of two arguments `x`, `y` and returns `out`. -/ +def computesFun₂ (env : List Value) (x y : Value) (body : PB → PB → PB) (out : Value) : Prop := + ∀ ext : List Value, ∃ t s, ProgSem (env ++ ext ++ [x, y]) + (body (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1)) + (env.length + ext.length + 2)) + out t s + +lemma computesFun₂_const {x y : Value} {impl : PB} {out : Value} + (h : impl.Computes env out) : + PB.computesFun₂ env x y (fun _ _ => impl) out := by + intro ext + simpa [List.append_assoc, Nat.add_assoc] using h (ext ++ [x, y]) + +/-- To run a one-argument branch `body` on the freshly-bound first argument (ignoring the second +binding), it suffices that `body` applied to the fresh variable computes `out` in the extended +environment. This hides the `Computes.here`/length bookkeeping of `computesFun₂`. -/ +lemma computesFun₂_branch {x y : Value} {body : PB → PB} {out : Value} + (h : ∀ ext, (body (PB.var (env.length + ext.length))).Computes (env ++ ext ++ [x, y]) out) : + computesFun₂ env x y (fun v _ => body v) out := by + intro ext + simpa [List.length_append, Nat.add_assoc] using (h ext).here + +/-- The code in `body` computes a function of one argument `x` and returns `out`. -/ +def computesFun₁ (env : List Value) (x : Value) (body : PB → PB) (out : Value) : Prop := + ∀ ext : List Value, ∃ t s, ProgSem (env ++ ext ++ [x]) + (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1)) + out t s + +/-- `elim`, nil branch: `v` computes `[]`, so the empty branch `em` runs. -/ +@[simp] +lemma elim_nil_computes {v em : PB} {cs : PB → PB → PB} {out : Value} + (hv : Computes env v (.data (.l []))) + (hem : Computes env em out) : + Computes env (PB.elim v em cs) out := by + intro ext + obtain ⟨tv, sv, hv'⟩ := hv ext + obtain ⟨tem, sem, hem'⟩ := hem ext + simp only [PB.elim] + exact ⟨_, _, ProgSem.elim_nil hv' hem'⟩ + +/-- `elim`, cons branch: `v` computes `head :: tail`, so the curried branch `cs` is applied to +`head` and then to `tail` (each application running an `fn` body in the extended environment). -/ +@[simp] +lemma elim_cons_computes {v em : PB} {cs : PB → PB → PB} + {head : Data} {tail : List Data} {out : Value} + (hv : Computes env v (.data (.l (head :: tail)))) + (hcs : computesFun₂ env (.data head) (.data (Data.l tail)) cs out) : + Computes env (PB.elim v em cs) out := by + intro ext + obtain ⟨tv, sv, hv'⟩ := hv ext + obtain ⟨tr, sr, hb⟩ := hcs ext + simp only [PB.elim] + have hmap : ((env ++ ext) ++ [Value.data head]) ++ [Value.data (Data.l tail)] + = env ++ ext ++ [head, Data.l tail].map Value.data := by + simp + have hb' : ProgSem + (((env ++ ext) ++ [Value.data head]) ++ [Value.data (Data.l tail)]) + (cs (PB.var (env.length + ext.length)) (PB.var (env.length + ext.length + 1)) + (env.length + ext.length + 2)) + out tr sr := by + rw [hmap]; exact hb + exact ⟨_, _, ProgSem.elim_cons hv' ProgSem.fn (AppSem.mk ProgSem.fn) (AppSem.mk hb')⟩ + +@[simp] +lemma ifeq_eq_computes {x y then_ else_ : PB} {vx : Data} {out : Value} + (hx : Computes env x (.data vx)) + (hy : Computes env y (.data vx)) + (hthen : Computes env then_ out) : + Computes env (PB.ifEq x y then_ else_) out := by + intro ext + obtain ⟨tx, sx, hx'⟩ := hx ext + obtain ⟨ty, sy, hy'⟩ := hy ext + obtain ⟨tthen, sthen, hthen'⟩ := hthen ext + simp only [PB.ifEq] + exact ⟨_, _, ProgSem.ifEq_then hx' hy' hthen'⟩ + +@[simp] +lemma ifeq_ne_computes {x y then_ else_ : PB} {vx vy : Data} {out : Value} + (hx : Computes env x (.data vx)) + (hy : Computes env y (.data vy)) + (hne : vx ≠ vy) + (helse : Computes env else_ out) : + Computes env (PB.ifEq x y then_ else_) out := by + intro ext + obtain ⟨tx, sx, hx'⟩ := hx ext + obtain ⟨ty, sy, hy'⟩ := hy ext + obtain ⟨telse, selse, helse'⟩ := helse ext + simp only [PB.ifEq] + exact ⟨_, _, ProgSem.ifEq_else hx' hy' hne helse'⟩ + +/-- In-place application of a literal abstraction (a `let` binding): if `arg` computes `dx` +and `body` computes `out` with its parameter bound to `dx`, then `app (fn body) arg` computes +`out`. -/ +lemma app_fn_computes {body : PB → PB} {arg : PB} {dx out : Value} + (harg : Computes env arg dx) + (hbody : computesFun₁ env dx body out) : + Computes env (PB.app (PB.fn body) arg) out := by + intro ext + obtain ⟨ta, sa, ha⟩ := harg ext + obtain ⟨tb, sb, hb⟩ := hbody ext + simp only [PB.app, fn] + have hmap : (env ++ ext) ++ [dx] + = (env ++ ext ++ [dx]) := by + simp + have hb' : ProgSem ((env ++ ext) ++ [dx]) + (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1)) + out tb sb := by + rw [hmap]; exact hb + exact ⟨_, _, ProgSem.app ProgSem.fn ha (AppSem.mk hb')⟩ + + +------------------- Resource Consumption ------------------------- + +def OutputsOSize (impl : PB) (s : List Value → ℕ) : Prop := + ∃ a b, ∀ env, ∃ out, + impl.Computes env out ∧ out.size ≤ a * (s env) + b + +def UsesOTime (impl : PB) (t : List Value → ℕ) : Prop := + ∃ a b, ∀ env, ∃ out s, ∃ t' ≤ a * (t env) + b, + ProgSem env (impl env.length) out t' s + +def UsesOSpace (impl : PB) (s : List Value → ℕ) : Prop := + ∃ a b, ∀ env, ∃ out t, ∃ s' ≤ a * (s env) + b, + ProgSem env (impl env.length) out t s' + +def UsesLinearTimeAndSpace (impl : PB) : Prop := + PB.UsesOTime impl (fun env => (env.map fun x => x.size).sum) ∧ + PB.UsesOSpace impl (fun env => (env.map fun x => x.size).sum) + +end PB + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean new file mode 100644 index 000000000..6d1a1d79a --- /dev/null +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -0,0 +1,201 @@ +/- +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.RTM.Data +public import Cslib.Computability.Machines.RTM.DataEncode + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +/-- +Prog is the syntax representation of a functional language that has a resource consumption +model which is compatible to that of a Turing machine. +The data structure it operates on is a rose tree (`Data`). The advantage of this data structure +is that the majority of lean data types have a direct encoding. +-/ +inductive Prog where + /-- Variable reference at de Bruijn level `id`. -/ + | var (id : ℕ) + /-- The empty constructor of `Data`. -/ + | empty + /-- The `cons` constructor of `Data`: prepend the value of `h` to the list value of `t`. -/ + | cons (h t : Prog) + /-- Destructor of `Data`: evaluate `v`; if it is `empty`, run `emp`; otherwise destructure into + `head` and `tail` and apply the function `cs` to `head` and then to `tail`. -/ + | elim (v emp cs : Prog) + /-- Equality comparison: If `x` evaluates to the same data as `y`, run `then_`, else + run `else_`. + This can be simulated using `while_` below, but it is useful to have. -/ + | ifEq (x y then_ else_ : Prog) + /-- While loop: evaluate `init` to the starting accumulator; `body` must evaluate + to a one-argument function which is applied to the current accumulator on each + iteration. Return the accumulator if its head is empty. -/ + | while_ (init body : Prog) + /-- Abstraction / closure in one variable. -/ + | fn (body : Prog) + /-- Function application. -/ + | app (fn arg : Prog) +deriving Repr + +/-- Runtime values for the semantics predicate `ProgSem`. -/ +inductive Value where + | data (d : Data) + | closure (body : Prog) (env : List Value) +deriving Repr + +def Value.size : Value → ℕ + | .data d => d.size + | .closure _ env => 2 + (env.map Value.size).sum + +/-- The empty first-order value. -/ +abbrev Value.empty : Value := .data (Data.l []) + +@[simp] +lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size] + +@[simp] +lemma Value.size_empty : Value.empty.size = 2 := by simp + +mutual +/-- Semantics of `Prog` including time and space resource bounds. +`ProgSem σ p x t s` means that on environment `σ`, the program `p` evaluates to the value +`x` and uses `t` time and `s` space. -/ +inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop + | var : + ProgSem σ (.var i) (σ[i]?.getD Value.empty) + (σ[i]?.getD Value.empty).size (σ[i]?.getD Value.empty).size + | empty : ProgSem σ .empty Value.empty 2 2 + | cons (h₁ : ProgSem σ head (.data hd) hd_t hd_s) (h₂ : ProgSem σ tail (.data tl) tl_t tl_s) : + ProgSem σ (.cons head tail) (.data (Data.l (hd :: tl.asList))) (hd_t + tl_t) (hd_s + tl_s) + /-- `elim`, empty branch: `v` is the empty list, so run `emp` in the current environment. -/ + | elim_nil + (h₁ : ProgSem σ val (.data (Data.l [])) t_v s_v) + (h₂ : ProgSem σ emp r t_emp s_emp) : + ProgSem σ (.elim val emp cs) r (t_v + t_emp) (max s_v s_emp) + /-- `elim`, cons branch: `v` destructures to `hd :: tl`; evaluate the function `cs` to a + closure and apply it first to `hd` and then to `tl` (so `cs` is a curried + two-argument function). -/ + | elim_cons + (h_v : ProgSem σ val (.data (Data.l (hd :: tl))) t_v s_v) + (h_cs : ProgSem σ cs cv t_cs s_cs) + (h_app₁ : AppSem cv (.data hd) cv' t₁ s₁) + (h_app₂ : AppSem cv' (.data (Data.l tl)) r t₂ s₂) : + ProgSem σ (.elim val emp cs) r (t_v + t_cs + t₁ + t₂) + (max (max (max s_v s_cs) s₁) s₂) + | ifEq_then + (h_x : ProgSem σ x (.data vx) t_x s_x) + (h_y : ProgSem σ y (.data vx) t_y s_y) + (h_then : ProgSem σ then_ r t_then s_then) : + ProgSem σ (.ifEq x y then_ else_) r + (t_x + t_y + t_then) + (max (max s_x s_y) s_then) + | ifEq_else + (h_x : ProgSem σ x (.data vx) t_x s_x) + (h_y : ProgSem σ y (.data vy) t_y s_y) + (h_neq : vx ≠ vy) + (h_else : ProgSem σ else_ r t_else s_else) : + ProgSem σ (.ifEq x y then_ else_) r + (t_x + t_y + t_else) + (max (max s_x s_y) s_else) + /-- `while_ init body`: evaluate `init` to the starting accumulator and `body` to a + one-argument closure, then iterate the closure via `WhileSem` until it halts. -/ + | while_ + (h_init : ProgSem σ init (.data acc) t_init s_init) + (h_body : ProgSem σ body bodyVal t_body s_body) + (h_while : WhileSem bodyVal acc r t_w s_w) : + ProgSem σ (.while_ init body) (.data r) (t_init + t_body + t_w) + (max (max s_init s_body) s_w) + /-- `fn body`: evaluate to a closure capturing the current environment `σ`. The cost is the + size of the resulting closure (mirroring `var`, which charges the size of the value it + produces). + TODO: We could charge only the size of the referenced variables, which would make it + more or less free to create a non-capturing closure. + TODO: An earlier version did not charge for the environment in case an abstraction is directly + applied (more specifically, it did not even have abstractions or closures), + which makes it easier to simulate on a Turing machine. -/ + | fn : + ProgSem σ (.fn body) (.closure body σ) + (Value.closure body σ).size (Value.closure body σ).size + /-- `app fn arg`: evaluate `fn` to a closure, evaluate `arg` to a value, then run the + closure's body in the *captured* environment extended with the argument (static + scoping). -/ + | app + (h_fn : ProgSem σ fn fv t_f s_f) + (h_arg : ProgSem σ arg v t_a s_a) + (h_app : AppSem fv v r t_b s_b) : + ProgSem σ (.app fn arg) r (t_f + t_a + t_b) (max (max s_f s_a) s_b) + +/-- Application of a value to an argument value. `AppSem f v r t s` means that applying the +closure `f` to the argument `v` yields `r` using `t` time and `s` space. Only closures can be +applied; applying a first-order value has no derivation (the program is stuck). -/ +inductive AppSem : Value → Value → Value → ℕ → ℕ → Prop + | mk (h_body : ProgSem (σ' ++ [v]) body r t s) : + AppSem (.closure body σ') v r t s + +/-- Iterates the closure `bodyVal` of a `while_` loop, threading the accumulator. +`WhileSem bodyVal acc r t s` means that, starting from accumulator `acc`, repeatedly applying +`bodyVal` to the current accumulator eventually yields result `r` using `t` time and `s` space. +Before each iteration the halting condition is checked on the current accumulator: iteration +terminates (with the accumulator as result) when `acc` is empty or its head is empty. +Otherwise `bodyVal` is applied and its result becomes the new accumulator. Non-terminating +loops simply have no derivation. -/ +inductive WhileSem : Value → Data → Data → ℕ → ℕ → Prop + | halt + (h_stop : acc.asList.head?.getD (Data.l []) = Data.l []) : + WhileSem bodyVal acc acc acc.size acc.size + | step + (h_cont : acc.asList.head?.getD (Data.l []) ≠ Data.l []) + (h_app : AppSem bodyVal (.data acc) (.data v) t_b s_b) + (h_rest : WhileSem bodyVal v r t_r s_r) : + WhileSem bodyVal acc r (t_b + t_r) (max s_b s_r) +end + +/-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/ +def Prog.ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop := + ProgSem [.data x] p (.data y) t s + +/-- The program `p` computes the function `f` (on binary strings) in time `t` and space `s`. +This is the main definition that defines complexity for this computation model. -/ +def Prog.ComputesBoolFunInTimeAndSpace + (p : Prog) (f : List Bool → List Bool) (t : ℕ → ℕ) (s : ℕ → ℕ) : Prop := + ∀ x, ∃ t' ≤ t x.length, ∃ s' ≤ s x.length, + Prog.ComputesInTimeAndSpace p (DataEncode.encode x) (DataEncode.encode (f x)) t' s' + +/-- The *in-place* (first-order) fragment of the functional language. + +`InPlace p` holds when every `fn` in `p` occurs in an immediately-consumed position — as the +operator of an `app`, or as the (curried) branch of an `elim`/`while_`. Consequently no +closure ever escapes: every abstraction is created and used on the spot, so all values that +flow through the environment are first-order `Data`. This is exactly the fragment a +defunctionalising compiler targets, and it is closed under the operational semantics. + +A Turing machine can directly implement this fragment without the need for closures: +One tape is used for each "node" in the syntax tree. +-/ +inductive InPlace : Prog → Prop + | var : InPlace (.var i) + | empty : InPlace .empty + | cons (hh : InPlace h) (ht : InPlace t) : InPlace (.cons h t) + /-- `elim` over an in-place value, empty branch, and a curried two-argument function + branch `fn (fn body)` binding `head` and `tail`. -/ + | elim (hv : InPlace v) (hemp : InPlace emp) (hbody : InPlace body) : + InPlace (.elim v emp (.fn (.fn body))) + | ifEq (hx : InPlace x) (hy : InPlace y) (hthen : InPlace then_) (helse : InPlace else_) : + InPlace (.ifEq x y then_ else_) + /-- `while_` whose body is a literal one-argument function `fn body` binding the + accumulator. -/ + | while_ (hinit : InPlace init) (hbody : InPlace body) : + InPlace (.while_ init (.fn body)) + + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean new file mode 100644 index 000000000..323ffd03d --- /dev/null +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -0,0 +1,1089 @@ +/- +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.RTM.Tools +public import Cslib.Computability.Machines.SingleTapeTuring.Basic +public import Mathlib.Data.List.ReduceOption + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +-- TODO Working on the resource bounds now. +-- The proof outline should be: +-- each iteration of the loop causes the accumulator to grow by at most a constant. +-- this can actually be shown from the semantics and the proof that the tape size grows by at +-- most a constant. +-- then, we show that the time and space of each iteration is linear in its input. +-- so overall, t iterations are computed in O(t^2) time and O(t) space. + +variable [DataEncode Symbol] + +variable {env : List Value} + +public instance : DataEncode (Turing.StackTape Symbol) where + encode t := DataEncode.encode t.toList + h_inj := by + intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h + grind [DataEncode.h_inj h] + +public instance : DataEncode (Turing.BiTape Symbol) where + encode t := DataEncode.encode (t.head, t.left, t.right) + h_inj := by + intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h + grind [DataEncode.h_inj h] + +lemma encode_biTape (t : Turing.BiTape Symbol) : + DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by + simp [DataEncode.encode] + +def bitape_write (t v : PB) : PB := PB.cons v t.tail + +lemma bitape_write_computes + {p_tape p_sym : PB} {tape : BiTape Symbol} {sym : Option Symbol} + (h_tape : p_tape.ComputesEnc env tape) + (h_sym : p_sym.ComputesEnc env sym) : + (bitape_write p_tape p_sym).ComputesEnc env (tape.write sym) := by + apply PB.cons_computes h_sym (PB.tail_computes h_tape) + +-- /-- Prepend an `Option` to the `StackTape` -/ +-- @[scoped grind] +-- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol := +-- match x, xs with +-- | none, ⟨[], _⟩ => ⟨[], by grind⟩ +-- | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩ +-- | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩ + +def stackTapeCons (x st : PB) : PB := + PB.optionElim x + (PB.elim st + PB.empty + (fun _ _ => PB.cons x st)) + (fun _ => PB.cons x st) + +lemma stackTapeCons_computes + {p_x p_st : PB} {x : Option Symbol} {st : StackTape Symbol} + (h_x : p_x.ComputesEnc env x) + (h_st : p_st.ComputesEnc env st) : + (stackTapeCons p_x p_st).ComputesEnc env (st.cons x) := by + cases x with + | none => + apply PB.optionElim_computesEnc_none h_x + obtain ⟨l, hl⟩ := st + cases l with + | nil => apply PB.elim_nil_computes h_st (PB.empty_computes) + | cons hd tl => + apply PB.elim_cons_computes h_st + (PB.computesFun₂_const (PB.cons_computes h_x h_st)) + | some a => + apply PB.optionElim_computesEnc_some h_x + (PB.computesFun₂_const (PB.cons_computes h_x h_st)) + +--- The head component of the bitape +def bitapeHead (t : PB) : PB := t.fst +--- The left component of the bitape +def bitapeLeft (t : PB) : PB := t.snd.fst +--- The right component of the bitape +def bitapeRight (t : PB) : PB := t.snd.snd + +lemma bitapeHead_computes {p_t : PB} {t : BiTape Symbol} + (h_t : p_t.ComputesEnc env t) : + (bitapeHead p_t).ComputesEnc env t.head := PB.head_computes h_t + +lemma bitapeLeft_computes {p_t : PB} {t : BiTape Symbol} + (h_t : p_t.ComputesEnc env t) : + (bitapeLeft p_t).ComputesEnc env t.left := + PB.head_computes (PB.head_computes (PB.tail_computes h_t)) + +lemma bitapeRight_computes {p_t : PB} {t : BiTape Symbol} + (h_t : p_t.ComputesEnc env t) : + (bitapeRight p_t).ComputesEnc env t.right := + PB.head_computes (PB.tail_computes (PB.head_computes (PB.tail_computes h_t))) + +lemma encode_stackTape_head (st : StackTape Symbol) : + (DataEncode.encode st).asList.headD (Data.l []) = DataEncode.encode st.head := by + obtain ⟨l, hl⟩ := st + cases l <;> simp [DataEncode.encode, StackTape.head, Data.asList] + +lemma encode_stackTape_tail (st : StackTape Symbol) : + Data.l (DataEncode.encode st).asList.tail = DataEncode.encode st.tail := by + obtain ⟨l, hl⟩ := st + cases l <;> simp [DataEncode.encode, StackTape.tail, Data.asList] + +lemma stackTapeHead_computes {p_st : PB} {st : StackTape Symbol} + (h_st : p_st.ComputesEnc env st) : + (p_st.head).ComputesEnc env st.head := by + unfold PB.ComputesEnc + simpa [← encode_stackTape_head] using PB.head_computes h_st + +lemma stackTapeTail_computes {p_st : PB} {st : StackTape Symbol} + (h_st : PB.ComputesEnc env p_st st) : + (p_st.tail).ComputesEnc env st.tail := by + unfold PB.ComputesEnc + simpa [← encode_stackTape_tail] using PB.tail_computes h_st + +-- def move_left (t : BiTape Symbol) : BiTape Symbol := +-- ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩ + +def bitapeMoveLeft (t : PB) : PB := + PB.toPair (bitapeLeft t).head + (PB.toPair + (bitapeLeft t).tail + (stackTapeCons (bitapeHead t) (bitapeRight t))) + +lemma bitapeMoveLeft_computes {p_t : PB} {t : BiTape Symbol} (h_t : p_t.ComputesEnc env t) : + PB.ComputesEnc env (bitapeMoveLeft p_t) t.moveLeft := + PB.toPair_computesEnc + (stackTapeHead_computes (bitapeLeft_computes h_t)) + (PB.toPair_computesEnc + (stackTapeTail_computes (bitapeLeft_computes h_t)) + (stackTapeCons_computes (bitapeHead_computes h_t) (bitapeRight_computes h_t))) + +-- def move_right (t : BiTape Symbol) : BiTape Symbol := +-- ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩ + +def bitapeMoveRight (t : PB) : PB := + PB.toPair (bitapeRight t).head + (PB.toPair + (stackTapeCons (bitapeHead t) (bitapeLeft t)) + (bitapeRight t).tail) + +lemma bitapeMoveRight_computes {p_t : PB} {t : BiTape Symbol} (h_t : p_t.ComputesEnc env t) : + (bitapeMoveRight p_t).ComputesEnc env t.moveRight := + PB.toPair_computesEnc + (stackTapeHead_computes (bitapeRight_computes h_t)) + (PB.toPair_computesEnc + (stackTapeCons_computes (bitapeHead_computes h_t) (bitapeLeft_computes h_t)) + (stackTapeTail_computes (bitapeRight_computes h_t))) + +instance : DataEncode Dir where + encode := fun + | Dir.left => DataEncode.encode true + | Dir.right => DataEncode.encode false + h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode] + +-- /-- +-- Move the head to the left or right, shifting the tape underneath it. +-- -/ +-- def move (t : BiTape Symbol) : Dir → BiTape Symbol +-- | .left => t.move_left +-- | .right => t.move_right + +def bitapeMove (tape dir : PB) : PB := + PB.ifEq dir (PB.constantEnc Dir.left) + (bitapeMoveLeft tape) + (bitapeMoveRight tape) + +lemma bitapeMove_computes {p_t p_dir : PB} {t : BiTape Symbol} {d : Dir} + (h_t : p_t.ComputesEnc env t) + (h_dir : p_dir.ComputesEnc env d) : + (bitapeMove p_t p_dir).ComputesEnc env (t.move d) := + match d with + | .left => + PB.ifeq_eq_computes h_dir PB.constantEnc_computesEnc (bitapeMoveLeft_computes h_t) + | .right => + PB.ifeq_ne_computes h_dir PB.constantEnc_computesEnc (by decide) (bitapeMoveRight_computes h_t) + +-- /-- +-- Optionally perform a `move`, or do nothing if `none`. +-- -/ +-- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol +-- | t, none => t +-- | t, some d => t.move d + +def bitapeOptionMove (t dir : PB) : PB := + PB.optionElim dir + t + (fun d => bitapeMove t d) + +lemma bitapeOptionMove_computes {p_t p_dir : PB} + {t : BiTape Symbol} {d : Option Dir} + (h_t : p_t.ComputesEnc env t) + (h_dir : p_dir.ComputesEnc env d) : + (bitapeOptionMove p_t p_dir).ComputesEnc env (t.optionMove d) := by + cases d with + | none => exact PB.optionElim_computesEnc_none h_dir h_t + | some d => + refine PB.optionElim_computesEnc_some h_dir (PB.computesFun₂_branch (fun ext => ?_)) + exact bitapeMove_computes (h_t.extend_append ext _) (PB.var_computes_fresh ext _) + +instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] : + DataEncode (Turing.SingleTapeTM.Cfg tm) where + encode cfg := DataEncode.encode (cfg.state, cfg.BiTape) + h_inj := by + intro ⟨s₁, t₁⟩ ⟨s₂, t₂⟩ h + have heq := DataEncode.h_inj h + simp at heq + obtain ⟨hs, ht⟩ := heq + cases hs; cases ht; rfl + +-- Evaluate a function `f` at `arg` where the function is given as a graph. +-- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise. +def eval_fun_graph (graph : PB) (arg : PB) : PB := + PB.fold + (fun acc x => + PB.optionElim acc + (PB.ifEq x.fst arg (PB.some x.snd) PB.empty) + fun _ => acc) + PB.empty graph + +/-- Semantic spec of `eval_fun_graph`: given an encoded graph (list of +`(α × β)`-pairs) and an encoded argument `a : α`, returns +`(graph.find? (·.1 = a)).map (·.2)`, i.e. `some y` for the first pair `(a, y)` +in the graph, else `none`. -/ +lemma eval_fun_graph_computes + {α β : Type} [DataEncode α] [DataEncode β] [DecidableEq α] + {env : List Data} {p_graph p_arg : PB} + {graph : List (α × β)} {a : α} + (h_graph : p_graph.computes_enc env graph) + (h_arg : p_arg.computes_enc env a) : + (eval_fun_graph p_graph p_arg).computes_enc env + ((graph.find? (fun p => p.1 = a)).map (·.2)) := by + -- The Lean-level step function for the fold. + let step : Option β → α × β → Option β := + fun acc x => acc.elim (if x.1 = a then some x.2 else none) (fun _ => acc) + -- Once the accumulator is `some _`, it stays `some _`. + have stays : ∀ (l : List (α × β)) (b : β), l.foldl step (some b) = some b := by + intro l b + induction l with + | nil => simp + | cons hd tl ih => simp [step, ih] + -- `foldl step none` matches `find?`-then-`map snd`. + have key : ∀ l : List (α × β), + l.foldl step none = (l.find? (fun p => p.1 = a)).map (·.2) := by + intro l + induction l with + | nil => simp + | cons hd tl ih => + simp only [List.foldl_cons, List.find?_cons] + by_cases h : hd.1 = a + · simp [step, h, stays] + · simp [step, h, ih] + rw [show (graph.find? (fun p => p.1 = a)).map (·.2) + = graph.foldl step none from (key graph).symm] + unfold eval_fun_graph + refine PB.fold_computes_enc (a := (none : Option β)) (f := step) + (by simp [PB.computes_enc, DataEncode.encode]) h_graph ?_ + intro acc x ext + rcases acc with _ | v + · -- acc = none: step none x = if x.1 = a then some x.2 else none + refine PB.optionElim_computes_none (α := β) + PB.elim_cons_head_var_computes ?_ + refine PB.ifEq_computes + (PB.fst_computes_enc PB.elim_cons_tail_var_computes) + (by simpa using h_arg.extend) ?_ ?_ + · intro h_enc + have h_eq : x.1 = a := DataEncode.h_inj h_enc + change PB.computes_enc _ _ (step none x) + simp only [step, Option.elim_none, if_pos h_eq] + exact PB.some_computes_enc + (PB.snd_computes_enc PB.elim_cons_tail_var_computes) + · intro h_enc + have h_ne : x.1 ≠ a := fun h => h_enc (by rw [h]) + simp [DataEncode.encode, step, h_ne] + · -- acc = some v: step (some v) x = some v + refine PB.optionElim_computes_some (α := β) + (PB.elim_cons_head_var_computes + (head := DataEncode.encode (some v : Option β))) ?_ + intro ext' + simpa [List.append_assoc, step] using PB.elim_cons_head_var_computes.extend + +-- def graphOf {α β : Type} [Fintype α] (f : α → β) : List (α × β) := +-- Fintype.elems.toList.map (fun a => (a, f a)) + +lemma eval_fun_graph_computes_of_fun + {α β : Type} [DataEncode α] [DataEncode β] [Fintype α] + {env : List Data} {p_graph p_arg : PB} + {a : α} + {f : α → β} + (h_graph : p_graph.computes_enc env (Fintype.elems.toList.map (fun a => (a, f a)))) + (h_arg : p_arg.computes_enc env a) : + (eval_fun_graph p_graph p_arg).head.computes_enc env (f a) := by + classical + have heq : ∀ (L : List α), a ∈ L → + ((L.map (fun a' => (a', f a'))).find? + (fun p => p.1 = a)).map (·.2) = some (f a) := by + intro L hmem + induction L with + | nil => exact absurd hmem (by simp) + | cons hd tl ih => grind + have h := eval_fun_graph_computes h_graph h_arg + rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h + simpa [DataEncode.encode, Data.asList] using PB.head_computes h + +def cfg_state (cfg : PB) : PB := cfg.fst +def cfg_bitape (cfg : PB) : PB := cfg.snd + +lemma cfg_state_computes [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} + (h : p.computes_enc env cfg) : + (cfg_state p).computes_enc env cfg.state := + PB.fst_computes_enc (a := (cfg.state, cfg.BiTape)) h + +lemma cfg_bitape_computes [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} + (h : p.computes_enc env cfg) : + (cfg_bitape p).computes_enc env cfg.BiTape := + PB.snd_computes_enc (a := (cfg.state, cfg.BiTape)) h + +/-- Evaluate the transition function. Returns `((wr, dir), q')`. + -- The return value is not wrapped inside an `Option` because the transition + -- function is assumed to be total. -/ +def eval_tr (tr : PB) (q c : PB) : PB := + (eval_fun_graph (eval_fun_graph tr q).head c).head + +instance : DataEncode (SingleTapeTM.Stmt Symbol) where + encode stmt := DataEncode.encode (stmt.symbol, stmt.movement) + h_inj := by + intro ⟨s₁, m₁⟩ ⟨s₂, m₂⟩ h + have heq := DataEncode.h_inj h + simp at heq + obtain ⟨hs, hm⟩ := heq + cases hs; cases hm; rfl + +lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State] + [DecidableEq State] [Fintype Symbol] + {env : List Data} {p_tr p_q p_c : PB} + {tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State} + {q : State} + {c : Option Symbol} + (h_tr : p_tr.computes_enc env + ((Fintype.elems : Finset State).toList.map (fun q' : State => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' : Option Symbol => (c', tr q' c')))))) + (h_q : p_q.computes_enc env q) + (h_c : p_c.computes_enc env c) : + (eval_tr p_tr p_q p_c).computes_enc env (tr q c) := by + unfold eval_tr + exact eval_fun_graph_computes_of_fun (α := Option Symbol) (f := tr q) + (eval_fun_graph_computes_of_fun (α := State) (f := fun q' => + (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c'))) + h_tr h_q) h_c + +-- /-- The step function corresponding to a `SingleTapeTM`. -/ +-- @[simp] +-- def step : tm.Cfg → Option tm.Cfg +-- | ⟨none, _⟩ => +-- -- If in the halting state, there is no next configuration +-- none +-- | ⟨some q', t⟩ => +-- -- If in state q', perform look up in the transition function +-- match tm.tr q' t.head with +-- -- and enter a new configuration with state q'' (or none for halting) +-- -- and tape updated according to the Stmt +-- | ⟨⟨wr, dir⟩, q''⟩ => some ⟨q'', (t.write wr).optionMove dir⟩ + +-- Compute the step function given a transition function (as its graph) and a configuration. +-- Returns `Option Cfg` +def singleTapeTM_step (tr : PB) (cfg : PB) : PB := + PB.optionElim (cfg_state cfg) + PB.empty + (fun q' => PB.letIn (cfg_bitape cfg) (fun tape => + PB.letIn (eval_tr tr q' tape.head) (fun tr_val => + .some (to_pair + tr_val.snd + (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd))))) + +-- TODO for space and time bounds, we need to prove for singleTapeTM_step, than: +-- for any `env`, +-- 1) the size of the output is the size of `env` plus a constant (not with a linear factor!) +-- 2) the time and space required is linear in the size of `env`. +-- the problematic bits are that we don't know what `tr` and `cfg` do, they are programs, +-- we cannot just look at their outputs +-- What is the right condition for `tr` and `cfg`? + +lemma singleTapeTM_step_computes [Inhabited Symbol] [Fintype Symbol] + [DecidableEq Symbol] {tm : SingleTapeTM Symbol} + [DataEncode tm.State] [DecidableEq tm.State] + {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg} + (h_tr : p_tr.computes_enc env + ((Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c')))))) + (h_cfg : p_cfg.computes_enc env cfg) : + (singleTapeTM_step p_tr p_cfg).computes_enc env (tm.step cfg) := by + unfold singleTapeTM_step + obtain ⟨state, t⟩ := cfg + match hst : state with + | none => + refine PB.optionElim_computes_none (cfg_state_computes h_cfg) ?_ + change PB.empty.computes_enc env (none : Option tm.Cfg) + simp [PB.computes_enc, DataEncode.encode] + | some q' => + refine PB.optionElim_computes_some (cfg_state_computes h_cfg) ?_ + intro ext1 + -- TODO letin makes this proof complicated. + -- Outer letIn: bind `tape := cfg_bitape p_cfg`, value `t`. + apply PB.letIn_computes_enc (v := t) + (by simpa [List.append_assoc] using cfg_bitape_computes h_cfg.extend) + intro ext2 + set env2 := env ++ ext1 ++ [DataEncode.encode q'] with env2_def + -- The slot for `q'` at depth `env.length + ext1.length`. + have h_q'_slot : PB.computes_enc + (env2 ++ ext2 ++ [DataEncode.encode t]) + (PB.atSlot (env.length + ext1.length)) q' := by + simpa [env2_def] using PB.atSlot_last_computes_enc.extend + -- The slot for `tape` at depth `env2.length + ext2.length`. + have h_tape_slot : PB.computes_enc + (env2 ++ ext2 ++ [DataEncode.encode t]) + (PB.atSlot (env2.length + ext2.length)) t := + PB.atSlot_last_computes_enc + apply PB.letIn_computes_enc + (eval_tr_computes + (by simpa [env2_def, List.append_assoc] using h_tr.extend) + h_q'_slot (bitape_head_computes h_tape_slot)) + intro ext3 + set env3 := env2 ++ ext2 ++ [DataEncode.encode t] with env3_def + set envS := env3 ++ ext3 ++ [DataEncode.encode (tm.tr q' t.head)] with envS_def + -- Re-derive tape slot at envS. + have h_tape_slot' : PB.computes_enc envS + (PB.atSlot (env2.length + ext2.length)) t := by + simpa [envS_def, env3_def, List.append_assoc] using + h_tape_slot.extend (ext := ext3 ++ [DataEncode.encode (tm.tr q' t.head)]) + -- Destructure the transition result. + rcases htr_eq : tm.tr q' t.head with ⟨⟨wr, dir⟩, q''⟩ + have h_trval : PB.computes_enc envS + (PB.atSlot (env3.length + ext3.length)) + (SingleTapeTM.Stmt.mk (Symbol := Symbol) wr dir, q'') := by + simp [envS_def, htr_eq] + unfold SingleTapeTM.step + simp only [htr_eq] + exact PB.some_computes_enc + (to_pair_computes + (PB.snd_computes_enc h_trval) + (bitape_optionMove_computes + (bitape_write_computes h_tape_slot' + (PB.fst_computes_enc (a := (wr, dir)) + (PB.fst_computes_enc h_trval))) + (PB.snd_computes_enc (a := (wr, dir)) + (PB.fst_computes_enc h_trval)))) + +def tm_main_loop (tr : PB) (cfg : PB) : PB := + -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step` + -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep + -- the current `acc` (which has `state = none`, signalling halt to `while_`). + PB.while_ cfg + (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next)) + +/-- The body of `tm_main_loop` computes one TM step (with `none` halt as fixed point). -/ +private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol] + [DecidableEq Symbol] {tm : SingleTapeTM Symbol} + [DataEncode tm.State] [DecidableEq tm.State] + {env : List Data} {p_tr : PB} + (h_tr : p_tr.computes_enc env + ((Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c')))))) + (c : tm.Cfg) : + PB.computes_at_body₁ env (DataEncode.encode c) + (fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next)) + (DataEncode.encode ((tm.step c).getD c)) := by + set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def + intro ext + set E := env ++ ext with E_def + have hE_len : E.length = env.length + ext.length := by simp [E_def] + have h_acc : PB.computes_enc (E ++ [DataEncode.encode c]) + (PB.atSlot E.length) c := by + simpa using PB.atSlot_last_computes_enc (env := E) (ext := []) (a := c) + have h_step_eval : + (singleTapeTM_step p_tr (PB.atSlot E.length)).computes_enc + (E ++ [DataEncode.encode c]) (tm.step c) := by + have h_tr_ext : PB.computes_enc (E ++ [DataEncode.encode c]) p_tr + ((Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c'))))) := by + have := h_tr.extend (ext := ext ++ [DataEncode.encode c]) + simpa [E_def, List.append_assoc] using this + exact singleTapeTM_step_computes h_tr_ext h_acc + change PB.computes_at (E ++ [DataEncode.encode c]) + (PB.optionElim (singleTapeTM_step p_tr (PB.atSlot (env.length + ext.length))) + (PB.atSlot (env.length + ext.length)) + (fun next => next)) (DataEncode.encode (step c)) + rw [← hE_len] + cases hstep_c : tm.step c with + | none => + rw [show step c = c from by simp only [step_def]; rw [hstep_c]; rfl] + exact PB.optionElim_computes_none (hstep_c ▸ h_step_eval) h_acc + | some next => + rw [show step c = next from by simp only [step_def]; rw [hstep_c]; rfl] + refine PB.optionElim_computes_some (hstep_c ▸ h_step_eval) ?_ + intro ext' + simpa using PB.atSlot_last_computes_enc + (env := E ++ [DataEncode.encode c]) (ext := ext') (a := next) + +/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from +`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none` +state), the loop computes the configuration obtained after the *minimal* such +number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the +halt result `none` as a fixed point via `Option.getD`. -/ +lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol] + [DecidableEq Symbol] {tm : SingleTapeTM Symbol} + [DataEncode tm.State] [DecidableEq tm.State] + {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg} + (h_tr : p_tr.computes_enc env + ((Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c')))))) + (h_cfg : p_cfg.computes_enc env cfg) + (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) : + (tm_main_loop p_tr p_cfg).computes_enc env + ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by + -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map. + set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def + -- `headD` of an encoded `Cfg` is empty iff the state is `none`. + have headD_iff : ∀ c : tm.Cfg, + (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by + rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList] + -- Translate the halting hypothesis through the iff. + have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] := + h_halts.imp fun _ h => (headD_iff _).mpr h + have find_eq : Nat.find h_halts' = Nat.find h_halts := + le_antisymm + (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts))) + (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts'))) + -- Reduce to a `while_` spec call. + change PB.computes_at env (tm_main_loop p_tr p_cfg) + (DataEncode.encode (step^[Nat.find h_halts] cfg)) + rw [← find_eq] + unfold tm_main_loop + exact PB.while_computes_iter (env := env) (p_init := p_cfg) + (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next)) + step cfg h_cfg (tm_main_loop_body_computes h_tr) h_halts' + +def reverse (x : PB) : PB := + PB.fold (fun acc el => PB.cons el acc) PB.empty x + +lemma reverse_computes {α : Type} [DataEncode α] + {env : List Data} {p : PB} {l : List α} + (h : p.computes_enc env l) : + (reverse p).computes_enc env l.reverse := by + unfold reverse + have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp + rw [h_fold] + apply PB.fold_computes_enc (by simp [PB.computes_enc]) h + -- TODO at this point, we should actually be able to just apply a combinator on the semantics + -- of PB.cons + intro acc el ext + have h_el : PB.computes_at + (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) + (PB.atSlot (env.length + ext.length + 1)) (DataEncode.encode el) := by + simpa using (PB.atSlot_last_computes (ext := ext ++ [DataEncode.encode acc])).extend + simpa [DataEncode.encode, Data.asList] using + PB.cons_computes h_el (by simpa using PB.atSlot_last_computes.extend) + +def list_map (x : PB) (f : PB → PB) : PB := + reverse (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty x) + +lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β] + {env : List Data} {p : PB} {l : List α} + {f : PB → PB} {g : α → β} + (h : p.computes_enc env l) + (hf : ∀ x : α, PB.computes_at_body₁_encoded env x f (g x)) : + (list_map p f).computes_enc env (l.map g) := by + unfold list_map + -- TODO simplify proof + have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).computes_enc + env (l.foldl (fun acc el => g el :: acc) []) := by + apply PB.fold_computes_enc (a := ([] : List β)) (f := fun acc el => g el :: acc) + (by simp [PB.computes_enc, DataEncode.encode]) h + intro acc el ext + have h_acc : PB.computes_at + (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) + (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by + simpa using (PB.atSlot_last_computes (env := env) (ext := ext) + (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el]) + have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).computes_enc + (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (g el) := by + simpa [List.append_assoc] using hf el (ext ++ [DataEncode.encode acc]) + simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_fel h_acc + have h_rev := reverse_computes h_fold + have h_eq : (l.foldl (fun acc el => g el :: acc) []).reverse = l.map g := by + rw [show l.foldl (fun acc el => g el :: acc) [] + = (l.map g).foldl (fun acc el => el :: acc) [] from + (List.foldl_map (f := g) (g := fun acc el => el :: acc) (l := l) (init := [])).symm] + simp + rwa [h_eq] at h_rev + +/-- Discards the `none` elements of a list of options, keeping the `some` payloads. -/ +def list_reduceOption (x : PB) : PB := + reverse (PB.fold + (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) + PB.empty x) + +lemma list_reduceOption_computes {α : Type} [DataEncode α] + {env : List Data} {p : PB} {l : List (Option α)} + (h : p.computes_enc env l) : + (list_reduceOption p).computes_enc env l.reduceOption := by + unfold list_reduceOption + set step : List α → Option α → List α := + fun acc el => match el with | none => acc | some y => y :: acc with step_def + -- Convert `reduceOption` to the foldl form of `step` (with reversed accumulator). We need + -- this generalized over the initial accumulator so the induction goes through. + have h_eq : ∀ (xs : List (Option α)) (init : List α), + (xs.foldl step init).reverse = init.reverse ++ xs.reduceOption := by + intro xs + induction xs with + | nil => intro init; simp [List.reduceOption] + | cons hd tl ih => + intro init + cases hd with + | none => simpa [step_def] using ih init + | some y => + have h1 : List.foldl step init (some y :: tl) = List.foldl step (y :: init) tl := by + simp [step_def] + rw [h1, ih (y :: init)] + simp [List.reduceOption] + have h_fold : (PB.fold + (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) PB.empty p + ).computes_enc env (l.foldl step []) := by + apply PB.fold_computes_enc + (a := ([] : List α)) (f := step) + (by simp [PB.computes_enc, DataEncode.encode]) h + intro acc el ext + have h_el : (PB.atSlot (env.length + ext.length + 1)).computes_enc + (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) el := by + simpa [PB.computes_enc] using + (PB.atSlot_last_computes (ext := ext ++ [DataEncode.encode acc])).extend + have h_acc : (PB.atSlot (env.length + ext.length)).computes_enc + (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) acc := by + simpa [PB.computes_enc] using + (PB.atSlot_last_computes (env := env) (ext := ext) + (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el]) + cases el with + | none => + simpa [step_def] using + PB.optionElim_computes_none (α := α) h_el h_acc + | some y => + refine PB.optionElim_computes_some (α := α) h_el ?_ + intro ext' + -- Inside someCase, the bound `y` lives at slot + -- `env.length + ext.length + 2 + ext'.length`; `acc` is still at `env.length + ext.length`. + set ext_inner := + ext ++ [DataEncode.encode acc, DataEncode.encode (some y)] ++ ext' with ext_inner_def + have hlen : ext_inner.length = ext.length + 2 + ext'.length := by + simp [ext_inner_def, Nat.add_comm, Nat.add_left_comm] + have h_y : + PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y]) + (PB.atSlot (env.length + ext.length + 2 + ext'.length)) + (DataEncode.encode y) := by + have h := PB.atSlot_last_computes + (env := env) (ext := ext_inner) (d := DataEncode.encode y) + rw [hlen] at h + convert h using 2 + omega + have h_acc' : + PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y]) + (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by + have h := (h_acc : + PB.computes_at (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode (some y)]) + _ (DataEncode.encode acc)).extend (ext := ext' ++ [DataEncode.encode y]) + simpa [ext_inner_def, List.append_assoc] using h + have h_cons := PB.cons_computes h_y h_acc' + simp only [ext_inner_def] at h_cons + simpa [step_def, DataEncode.encode, Data.asList, List.append_assoc] using h_cons + have h_rev := reverse_computes h_fold + have h_eq₀ : (l.foldl step []).reverse = l.reduceOption := by simpa using h_eq l [] + rwa [h_eq₀] at h_rev + +def list_head_option (input : PB) : PB := + PB.elim input PB.empty (fun hd _tl => PB.some hd) + +lemma list_head_option_computes {α : Type} [DataEncode α] + {env : List Data} {p : PB} {l : List α} + (h : p.computes_enc env l) : + (list_head_option p).computes_enc env l.head? := by + cases l with + | nil => + apply PB.elim_nil_computes (em := PB.empty) + · simpa [DataEncode.encode] using h + · simp [DataEncode.encode] + | cons hd tl => + apply PB.elim_cons_computes (head := DataEncode.encode hd) + (tail := tl.map DataEncode.encode) + · simpa [DataEncode.encode] using h + · intro ext + simpa [DataEncode.encode] using + PB.cons_computes PB.elim_cons_head_var_computes PB.empty_computes + +def string_to_tape (input : PB) : PB := + to_pair (list_head_option input) (to_pair .empty (list_map input.tail PB.some)) + +lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Symbol} + (h_input : p_input.computes_enc env input) : + (string_to_tape p_input).computes_enc env (BiTape.mk₁ input) := by + have h_tail : (PB.tail p_input).computes_enc env input.tail := by + simpa [PB.computes_enc, DataEncode.encode] using PB.tail_computes h_input + have h_map : (list_map (PB.tail p_input) PB.some).computes_enc env + (StackTape.map_some input.tail : Turing.StackTape Symbol) := by + simpa [PB.computes_enc, DataEncode.encode] + using list_map_computes h_tail (fun _ _ => by + simpa [DataEncode.encode] using + PB.cons_computes PB.atSlot_last_computes PB.empty_computes) + have h_empty : (PB.empty : PB).computes_enc env (∅ : Turing.StackTape Symbol) := by + simp [PB.computes_enc, DataEncode.encode] + simpa [PB.computes_enc, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape] + using to_pair_computes (list_head_option_computes h_input) + (to_pair_computes h_empty h_map) + + +def initial_config (q₀ : PB) (input : PB) : PB := + to_pair (PB.some q₀) (string_to_tape input) + +/-- Turn the final config to an output, by taking the head and the right part of the tape + and discarding the blank (`none`) cells. -/ +def final_config_to_output (cfg : PB) : PB := + list_reduceOption (PB.cons (bitapeHead cfg.snd) (bitapeRight cfg.snd)) + +/-- Implements a universal Single-Tape TM, assuming that the input contains the following: +((initialState, transitionFunction), input). +If it terminates, the output is the tape contents under the head and to its right. -/ +def universal_tm (input : PB) := + final_config_to_output + (tm_main_loop input.fst.snd (initial_config input.fst.fst input.snd)) + +lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {env : List Data} {p_q₀ p_input : PB} {input : List Symbol} + (h_q₀ : p_q₀.computes_enc env tm.q₀) + (h_input : p_input.computes_enc env input) : + (initial_config p_q₀ p_input).computes_enc env (tm.initCfg input) := by + -- `tm.initCfg input = ⟨some tm.q₀, BiTape.mk₁ input⟩`, and `encode` on `Cfg` goes + -- through the `(state, BiTape)` pair, so this matches `to_pair`. + exact to_pair_computes (PB.some_computes_enc h_q₀) (string_to_tape_computes h_input) + +lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {env : List Data} {p_cfg : PB} {cfg : tm.Cfg} + (h_cfg : p_cfg.computes_enc env cfg) : + (final_config_to_output p_cfg).computes_enc env + (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := by + unfold final_config_to_output + have h_BiTape : (p_cfg.snd).computes_enc env cfg.BiTape := + PB.snd_computes_enc (a := (cfg.state, cfg.BiTape)) h_cfg + have h_head := bitape_head_computes h_BiTape + have h_right := bitape_right_computes h_BiTape + -- The inner `cons` builds the encoding of `head :: right.toList` (a `List (Option Symbol)`), + -- then `list_reduceOption` discards the blanks. + have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).computes_enc env + (cfg.BiTape.head :: cfg.BiTape.right.toList) := by + change PB.computes_at env _ (DataEncode.encode (cfg.BiTape.head :: cfg.BiTape.right.toList)) + simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_head h_right + exact list_reduceOption_computes h_list + +lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] + {env : List Data} {p_input : PB} {input : List Symbol} + (h_input : p_input.computes_enc env + ((tm.q₀, + (Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c'))))), + input)) + (h_halts : ∃ n, + ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none) : + (universal_tm p_input).computes_enc env + (let cfg := (fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg input) + (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption) := by + unfold universal_tm + have h_fst := PB.fst_computes_enc h_input + have h_q₀ := PB.fst_computes_enc h_fst + have h_tr := PB.snd_computes_enc h_fst + have h_inp := PB.snd_computes_enc h_input + exact final_config_to_output_computes + (tm_main_loop_computes h_tr (initial_config_computes h_q₀ h_inp) h_halts) + +/-- The output of reading the tape from `BiTape.mk₁ l` (head + right, then discarding +blanks) recovers `l`. -/ +private lemma reduceOption_mk₁_tape {Symbol : Type} (l : List Symbol) : + ((BiTape.mk₁ l).head :: (BiTape.mk₁ l).right.toList).reduceOption = l := by + have h : ∀ xs : List Symbol, (xs.map Option.some).reduceOption = xs := fun xs => by + induction xs with + | nil => rfl + | cons _ _ ih => simp [ih] + cases l <;> simp [BiTape.mk₁, Turing.StackTape.map_some_toList, h] + +/-- For a `SingleTapeTM` `tm` and any input `w`, if `tm` outputs `w'` on input `w`, +then the universal Turing machine `universal_tm`, when given an encoding of `tm` +together with `w`, computes `w'`. + +The encoded input has the shape `((tm.q₀, transitionTable), w)`, where +`transitionTable` enumerates `tm.tr` over all `(state, head symbol)` pairs. -/ +theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] + {env : List Data} {p_input : PB} {w w' : List Symbol} + (h_input : p_input.computes_enc env + ((tm.q₀, + (Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c'))))), + w)) + (h_out : tm.Outputs w w') : + (universal_tm p_input).computes_enc env w' := by + -- Lift `tm.step` to a total step function; halting states are fixed points. + set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep + have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by + rintro ⟨_, _⟩ rfl; rfl + have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by + intro k _ hc + induction k with + | zero => rfl + | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc] + -- Convert `ReflTransGen` into an explicit step count via tail-induction. + obtain ⟨n, hn⟩ : ∃ n, step^[n] (tm.initCfg w) = tm.haltCfg w' := by + suffices h : ∀ {c c' : tm.Cfg}, Relation.ReflTransGen tm.TransitionRelation c c' → + ∃ n, step^[n] c = c' from h h_out + intro c c' hrel + induction hrel with + | refl => exact ⟨0, rfl⟩ + | tail _ h' ih => + obtain ⟨n, hn⟩ := ih + refine ⟨n + 1, ?_⟩ + rw [Function.iterate_succ_apply', hn] + change (tm.step _).getD _ = _ + rw [h'] + rfl + -- The halting hypothesis required by `universal_tm_computes`. + have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]; rfl⟩ + -- Determinism + stationarity: `Nat.find` of the halt index also reaches `haltCfg w'`. + have h_find : step^[Nat.find h_halts] (tm.initCfg w) = tm.haltCfg w' := by + have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn]; rfl) + have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts) + rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le, hn] at h_iter + exact h_iter.symm + -- Conclude via `universal_tm_computes`. + have h := universal_tm_computes (tm := tm) h_input h_halts + rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) = + tm.haltCfg w' from h_find] at h + simpa [SingleTapeTM.haltCfg, reduceOption_mk₁_tape] using h + +/-- Bubble-down for `universal_tm`: if `universal_tm p_input` produces some encoded +output at `env`, then the inner `tm_main_loop` also produces some value at `env`. -/ +private lemma universal_tm_eval_some_imp_loop_eval_some + {p_input : PB} {env : List Data} {d : Data} + (h : (universal_tm p_input env.length).eval env = .some d) : + ∃ d', (tm_main_loop p_input.fst.snd + (initial_config p_input.fst.fst p_input.snd) env.length).eval env = .some d' := by + -- We chase `.some` through every `Part.bind` in the call chain. Each `bind` is + -- introduced by a `Prog` constructor in `meteredEval`; if the outer eval is + -- `.some`, the bound subexpression must be `.some` too. + set n := env.length with hn + set mloop : Prog := tm_main_loop p_input.fst.snd + (initial_config p_input.fst.fst p_input.snd) n with mloop_def + -- Bubble through `cons`: if `Prog.cons a b` evals to some, both subterms do. + have bd_cons : ∀ {a b : Prog} {env d}, + (Prog.cons a b).eval env = .some d → + (∃ da, a.eval env = .some da) ∧ (∃ db, b.eval env = .some db) := by + intro a b env d h + rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h + obtain ⟨⟨d', _, _⟩, hm, _⟩ := h + unfold Prog.meteredEval at hm + simp only [bind, Part.mem_bind_iff] at hm + obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm + obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest + refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩ + · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩ + · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩ + -- Bubble through `elim`: if `Prog.elim v em cs` evals to some, then `v` does. + have bd_elim : ∀ {v em cs : Prog} {env d}, + (Prog.elim v em cs).eval env = .some d → ∃ dv, v.eval env = .some dv := by + intro v em cs env d h + rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h + obtain ⟨⟨d', _, _⟩, hm, _⟩ := h + unfold Prog.meteredEval at hm + simp only [bind, Part.mem_bind_iff] at hm + obtain ⟨⟨ah, _, _⟩, ha, _⟩ := hm + refine ⟨ah, ?_⟩ + rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩ + -- Bubble through `fold`: if `Prog.fold body init list` evals to some, then `init` + -- and `list` do. + have bd_fold : ∀ {body init list : Prog} {env d}, + (Prog.fold body init list).eval env = .some d → + (∃ di, init.eval env = .some di) ∧ (∃ dl, list.eval env = .some dl) := by + intro body init list env d h + rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h + obtain ⟨⟨d', _, _⟩, hm, _⟩ := h + unfold Prog.meteredEval at hm + simp only [bind, Part.mem_bind_iff] at hm + obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm + obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest + refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩ + · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩ + · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩ + -- Now unfold `universal_tm = final_config_to_output (...)`, + -- `final_config_to_output cfg = list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))`, + -- `list_reduceOption = reverse (PB.fold ...)`, `reverse = PB.fold ...`. + -- At each step we bubble down through the relevant `Prog` constructor. + -- `universal_tm p_input` reduces to a `list_reduceOption (...)` whose innermost + -- list expression depends on `mloop`. Bubble through two `PB.fold`s, then through + -- `PB.cons`, then through `bitape_head/right` (which are `head`/`tail` chains, i.e. `elim`s) + -- to extract a `some` evaluation for `mloop`. + change (final_config_to_output (tm_main_loop p_input.fst.snd + (initial_config p_input.fst.fst p_input.snd)) n).eval env = .some d at h + unfold final_config_to_output list_reduceOption reverse at h + -- Two folds → cons → bitape_head/right (each `head`/`tail`/`fst`/`snd` is `elim` chain) + obtain ⟨_, ⟨d1, h1⟩⟩ := bd_fold h + obtain ⟨_, ⟨d2, h2⟩⟩ := bd_fold h1 + -- h2 : (PB.cons (bitape_head mloop'.snd) (bitape_right mloop'.snd)) n .eval env = some d2 + -- where mloop' = tm_main_loop ... + change (Prog.cons _ _).eval env = .some d2 at h2 + obtain ⟨⟨d3, h3⟩, _⟩ := bd_cons h2 + -- h3 : bitape_head (...).snd evaluates to some + -- bitape_head t = t.fst = head t = elim t empty (fun ...) + -- bitape_head (mloop').snd = head (head (tail mloop')) + change (Prog.elim _ _ _).eval env = .some d3 at h3 + obtain ⟨d4, h4⟩ := bd_elim h3 + -- h4 : (mloop').snd n .eval env = some d4. .snd = head (tail _). + change (Prog.elim _ _ _).eval env = .some d4 at h4 + obtain ⟨d5, h5⟩ := bd_elim h4 + -- h5 : (tail mloop') n .eval env = some d5. tail = elim _ empty (fun _ tl => tl). + change (Prog.elim _ _ _).eval env = .some d5 at h5 + obtain ⟨d6, h6⟩ := bd_elim h5 + -- h6 : mloop' n .eval env = some d6. Done. + exact ⟨d6, h6⟩ + +/-- Converse of `universal_tm_simulates` (loose form). If `universal_tm`, applied to +a correctly-encoded `((q₀, transitionTable), w)`, evaluates to `w'` under env `env`, +then there exists an iteration index `n` such that the TM is in a halt state and +the tape contents under the head (with blanks discarded) equal `w'`. -/ +theorem universal_tm_simulates_converse [Inhabited Symbol] [Fintype Symbol] + [DecidableEq Symbol] {tm : SingleTapeTM Symbol} + [DataEncode tm.State] [DecidableEq tm.State] + {env : List Data} {p_input : PB} {w w' : List Symbol} + (h_input : p_input.computes_enc env + ((tm.q₀, + (Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c'))))), + w)) + (h_out : (universal_tm p_input).computes_enc env w') : + ∃ n : ℕ, + let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) + cfg.state = none ∧ + (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' := by + set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep + by_cases h_halts : ∃ n, (step^[n] (tm.initCfg w)).state = none + · -- Halts: use forward direction to identify the output. + refine ⟨Nat.find h_halts, Nat.find_spec h_halts, ?_⟩ + have h_fwd := universal_tm_computes (tm := tm) h_input h_halts + -- Both `h_fwd` and `h_out` give an evaluation of `universal_tm p_input` at `env`; + -- since `Part.eval` is functional, the encoded values must agree, then apply + -- injectivity of `DataEncode.encode`. + have h1 := h_fwd [] + have h2 := h_out [] + simp only [List.length_nil, Nat.add_zero, List.append_nil] at h1 h2 + rw [h1] at h2 + have h_eq := Part.some_inj.mp (by exact_mod_cast h2) + exact DataEncode.h_inj h_eq + · -- Does not halt: derive a contradiction from `h_out` via `whileFrom_eval_some`. + exfalso + have h_eval := h_out [] + simp only [List.length_nil, Nat.add_zero, List.append_nil] at h_eval + obtain ⟨d, h_loop⟩ := universal_tm_eval_some_imp_loop_eval_some h_eval + -- Project `h_input` to get individual components. + have h_q₀ := PB.fst_computes_enc (PB.fst_computes_enc h_input) + have h_tr := PB.snd_computes_enc (PB.fst_computes_enc h_input) + have h_inp := PB.snd_computes_enc h_input + -- Initial config evaluates to `encode (tm.initCfg w)`. + have h_init_eval : (initial_config p_input.fst.fst p_input.snd env.length).eval env + = .some (DataEncode.encode (tm.initCfg w)) := by + have := (initial_config_computes h_q₀ h_inp) [] + simpa using this + -- Unfold tm_main_loop = PB.while_ init body. + set body_pb : PB → PB := + fun acc => PB.optionElim (singleTapeTM_step p_input.fst.snd acc) acc + (fun next => next) with body_pb_def + change (PB.while_ (initial_config p_input.fst.fst p_input.snd) body_pb env.length).eval env + = .some d at h_loop + set bd : Prog := body_pb (fun _ => .var env.length) (env.length + 1) with bd_def + change (Prog.while_ (initial_config p_input.fst.fst p_input.snd env.length) bd).eval env + = .some d at h_loop + rw [Prog.while_eval, h_init_eval, Part.bind_some] at h_loop + -- Extract the trajectory. + obtain ⟨m, traj, h_traj0, h_trajm, h_halt_at_m, h_steps⟩ := + Prog.whileFrom_eval_some h_loop + -- The body computes `step` at every config. + have h_body_eval : ∀ c : tm.Cfg, + bd.eval (env ++ [DataEncode.encode c]) = .some (DataEncode.encode (step c)) := by + intro c + have h := (tm_main_loop_body_computes h_tr c (ext := [])).here + simpa [bd_def, body_pb_def, PB.atSlot, hstep] using h + -- Induction: `traj k = encode (step^[k] (tm.initCfg w))` for `k ≤ m`. + have h_traj_eq : ∀ k, k ≤ m → traj k = DataEncode.encode (step^[k] (tm.initCfg w)) := by + intro k hk + induction k with + | zero => simpa using h_traj0 + | succ k ih => + have hkm : k < m := hk + have ih' := ih (Nat.le_of_lt hkm) + have h_step_k := (h_steps k hkm).2 + rw [ih', h_body_eval] at h_step_k + have h_eq : traj (k + 1) = DataEncode.encode (step (step^[k] (tm.initCfg w))) := + (Part.some_inj.mp h_step_k).symm + rw [h_eq, show step (step^[k] (tm.initCfg w)) = step^[k+1] (tm.initCfg w) from + (Function.iterate_succ_apply' step k _).symm] + -- Halt condition at `m` gives `state = none`. + have h_at_m : traj m = DataEncode.encode (step^[m] (tm.initCfg w)) := h_traj_eq m le_rfl + rw [← h_trajm, h_at_m] at h_halt_at_m + have headD_iff : ∀ c : tm.Cfg, + (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by + rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList] + exact h_halts ⟨m, (headD_iff _).mp h_halt_at_m⟩ + +/-- Local alternative output predicate: `tm` (lifted to a total step function) reaches +a halted configuration whose tape content (head followed by the right stack, with +blanks discarded) equals `w'`. Used to phrase the combined `iff` characterization +of `universal_tm`. -/ +private def Outputs' {Symbol : Type} [Inhabited Symbol] [Fintype Symbol] + (tm : SingleTapeTM Symbol) (w w' : List Symbol) : Prop := + ∃ n : ℕ, + let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) + cfg.state = none ∧ + (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' + +private theorem universal_tm_simulates_iff [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] + {env : List Data} {p_input : PB} {w w' : List Symbol} + (h_input : p_input.computes_enc env + ((tm.q₀, + (Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c'))))), + w)) : + Outputs' tm w w' ↔ (universal_tm p_input).computes_enc env w' := by + set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep_def + have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by + rintro ⟨_, _⟩ rfl; rfl + have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by + intro k _ hc + induction k with + | zero => rfl + | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc] + refine ⟨?_, ?_⟩ + · -- Forward: `Outputs' tm w w' → universal_tm computes w'`. + rintro ⟨n, h_halt_n, h_eq⟩ + have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, h_halt_n⟩ + have h := universal_tm_computes (tm := tm) h_input h_halts + -- Stationarity: any later iterate of a halted config equals it. + have h_le : Nat.find h_halts ≤ n := Nat.find_le h_halt_n + have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts) + rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le] at h_iter + rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) = + (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) from h_iter.symm, h_eq] at h + exact h + · -- Converse: directly from `universal_tm_simulates_converse`. + intro h_out + exact universal_tm_simulates_converse h_input h_out + + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean new file mode 100644 index 000000000..f4b032cc6 --- /dev/null +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -0,0 +1,152 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.RTM.PB +public import Cslib.Computability.Machines.RTM.DataEncode + +/-! # RoseTreeMachine V4 — Tools + +Derived program-builder combinators. Because the V4 builder keeps the same HOAS `elim` +signature as the first-order development, these definitions are identical to their +counterparts there; only the underlying semantics (functional `elim`/`while_`) differs. +-/ + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +namespace PB + +variable {env : List Value} +variable {α : Type} [DataEncode α] +variable {β : Type} [DataEncode β] + +/-- Returns the tail of a list-valued builder (`[]` when empty). -/ +def tail (x : PB) : PB := .elim x .empty (fun _hd tl => tl) + +/-- Returns the head of a list-valued builder (`Data.l []` when empty). -/ +def head (x : PB) : PB := .elim x .empty (fun hd _tl => hd) + +@[simp] +lemma tail_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : + (tail x).Computes env (.data (Data.l dx.asList.tail)) := by + obtain ⟨dx⟩ := dx + cases dx with + | nil => simpa [PB.tail] using elim_nil_computes hx empty_computes + | cons hd tl => + refine elim_cons_computes hx ?_ + intro ext + simpa [PB.computesFun₂, var] using + var_computesFun (binds := [.data hd, .data (Data.l tl)]) (j := 1) ext + +@[simp] +lemma head_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : + Computes env (PB.head x) (.data (dx.asList.headD (Data.l []))) := by + obtain ⟨dx⟩ := dx + cases dx with + | nil => simpa [PB.head] using elim_nil_computes hx empty_computes + | cons hd tl => + refine elim_cons_computes hx ?_ + intro ext + simpa [PB.computesFun₂, var] using + var_computesFun (binds := [.data hd, .data (Data.l tl)]) (j := 0) ext + +/-- First projection (`head`). -/ +def fst (x : PB) : PB := head x + +lemma fst_ComputesEnc {x : PB} {a : α × β} (hx : x.ComputesEnc env a) : + (fst x).ComputesEnc env a.fst := by + obtain ⟨a, b⟩ := a + apply PB.head_computes hx + +/-- Second projection (`head` of `tail`). -/ +def snd (x : PB) : PB := head (PB.tail x) + +lemma snd_ComputesEnc {x : PB} {a : α × β} (hx : x.ComputesEnc env a) : + (snd x).ComputesEnc env a.snd := by + obtain ⟨a, b⟩ := a + apply PB.head_computes (PB.tail_computes hx) + +/-- `Option.some` as a singleton list. -/ +def some (x : PB) : PB := cons x empty + +lemma some_ComputesEnc {x : PB} {a : α} (hx : x.ComputesEnc env a) : + (PB.some x).ComputesEnc env (Option.some a) := by + apply PB.cons_computes hx empty_computes + +/-- Eliminate an `Option`: on `none` (empty) run `noneCase`, on `some v` run `someCase v`. -/ +def optionElim (x noneCase : PB) (someCase : PB → PB) : PB := + elim x noneCase (fun v _ => someCase v) + +lemma optionElim_computesEnc_none + {x noneCase : PB} {someCase : PB → PB} + (hx : x.ComputesEnc env (none : Option α)) + {a : β} + (h_none : noneCase.ComputesEnc env a) : + (optionElim x noneCase someCase).ComputesEnc env a := by + apply PB.elim_nil_computes hx h_none + +lemma optionElim_computesEnc_some + {x noneCase : PB} {someCase : PB → PB} + {a : α} + {b : β} + (hx : x.ComputesEnc env (Option.some a)) + (h_some : PB.computesFun₂ env (.data (DataEncode.encode a)) (.data (Data.l [])) + (fun v _ => someCase v) (.data (DataEncode.encode b))) : + (optionElim x noneCase someCase).ComputesEnc env b := by + apply PB.elim_cons_computes (head := DataEncode.encode a) (tail := []) + (by simpa [ComputesEnc, DataEncode.encode] using hx) h_some + +/-- Build the two-element list `[a, b]` (used as an encoded pair). -/ +def toPair (a b : PB) : PB := cons a (PB.cons b empty) + +lemma toPair_computesEnc + {a : α} {b : β} {pa pb : PB} + (ha : pa.ComputesEnc env a) (hb : pb.ComputesEnc env b) : + (toPair pa pb).ComputesEnc env (a, b) := by + apply PB.cons_computes ha (PB.cons_computes hb empty_computes) + +/-- Program that evaluates to the constant `a`. -/ +def constant (a : Data) : PB := match a with + | Data.l [] => .empty + | Data.l (x :: xs) => .cons (constant x) (constant (Data.l xs)) + +@[simp] +lemma constant_computes {a : Data} : (constant a).Computes env (.data a) := by + induction a using Data.inductionL with + | nil => simp [constant] + | cons hd tl ih_hd ih_tl => + simpa [constant] using cons_computes ih_hd ih_tl + +def constantEnc {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a) + +@[simp] +lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : + (constantEnc a).ComputesEnc env a := by + simp [ComputesEnc, constantEnc] + +/-- `fold body init list`: left fold of `body` (taking `acc` then `el`) over `list`. + +Implemented with `while_` over a `[remaining, acc]` pair: the loop halts once `remaining` +(the *head* of the accumulator, which is what `while_` inspects) becomes empty; otherwise it +splits off the first element `el`, updates the accumulator to `[rest, body acc el]`, and +continues. The fold's result is the final `acc` (the second component). -/ +def fold (body : PB → PB → PB) (init list : PB) : PB := + snd (PB.while_ (PB.toPair list init) + (fun st => elim (PB.fst st) empty + (fun el rest => toPair rest (body (PB.snd st) el)))) + + + +end PB + +end RoseTreeMachine + +end Turing From 296c742c5f988ae52410cfd61e02aa922c4a8b64 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 11 Jun 2026 01:11:46 +0200 Subject: [PATCH 02/22] Step simulation. --- .../Machines/RTM/DataEncode.lean | 4 + Cslib/Computability/Machines/RTM/PB.lean | 119 +++++- .../Machines/RTM/TMSimulator.lean | 392 ++++++------------ Cslib/Computability/Machines/RTM/Tools.lean | 143 +++++++ 4 files changed, 390 insertions(+), 268 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/DataEncode.lean b/Cslib/Computability/Machines/RTM/DataEncode.lean index ed731e542..b4c601213 100644 --- a/Cslib/Computability/Machines/RTM/DataEncode.lean +++ b/Cslib/Computability/Machines/RTM/DataEncode.lean @@ -22,6 +22,10 @@ class DataEncode (α : Type) where encode : α → Data h_inj : encode.Injective +instance : DataEncode Data where + encode b := b + h_inj := by intros a b h_eq; grind + instance : DataEncode Bool where encode b := if b then Data.l [ Data.l [] ] else Data.l [] h_inj := by intros a b h_eq; grind diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index 5e2c5afac..d2de83d0f 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -71,13 +71,6 @@ lemma Computes.extend {impl : PB} {out : Value} (more : List Value) intro ext simpa [List.append_assoc, List.length_append, Nat.add_assoc] using h (more ++ ext) -/-- Variant of `Computes.extend` matching the left-associated environment shape `env ++ a ++ b` -produced by the eliminator combinators. -/ -lemma Computes.extend_append {impl : PB} {out : Value} (a b : List Value) - (h : Computes env impl out) : - Computes (env ++ a ++ b) impl out := by - rw [List.append_assoc]; exact h.extend (a ++ b) - /-- Analogon of `Computes`, but as a statement of the pre-encoded value. This allows statements that `PB`s compute functions on lean datatypes. -/ def ComputesEnc {α : Type} [DataEncode α] (env : List Value) (impl : PB) (x : α) := @@ -103,6 +96,23 @@ lemma var_computes_fresh {v : Value} (ext binds : List Value) : simp [List.length_append] simpa [hget] using var_computes (env := env ++ ext ++ (v :: binds)) hlt +/-- The `j`-th freshly-bound argument: the variable at level `env.length + ext.length + j` reads +`binds[j]` from the trailing bindings `binds`. Generalises `var_computes_fresh` to any position. -/ +lemma var_computes_fresh' (ext binds : List Value) {j : ℕ} (hj : j < binds.length) : + Computes (env ++ ext ++ binds) (PB.var (env.length + ext.length + j)) binds[j] := by + have hlt : env.length + ext.length + j < (env ++ ext ++ binds).length := by + simp only [List.length_append]; omega + have hget : (env ++ ext ++ binds)[env.length + ext.length + j]'hlt = binds[j] := by + rw [List.getElem_append_right (by simp [List.length_append])] + simp [List.length_append] + exact hget ▸ var_computes (env := env ++ ext ++ binds) hlt + +/-- A freshly-bound second argument: the variable at level `env.length + ext.length + 1` reads the +second of the trailing bindings `v :: w :: binds`. Specialises `var_computes_fresh'` to `j = 1`. -/ +lemma var_computes_fresh2 {v w : Value} (ext binds : List Value) : + Computes (env ++ ext ++ (v :: w :: binds)) (PB.var (env.length + ext.length + 1)) w := by + exact var_computes_fresh' ext (v :: w :: binds) (j := 1) (by simp) + @[simp] lemma empty_computes : Computes env empty (.data (.l [])) := by intro ext @@ -151,12 +161,32 @@ lemma computesFun₂_branch {x y : Value} {body : PB → PB} {out : Value} intro ext simpa [List.length_append, Nat.add_assoc] using (h ext).here +/-- Two-argument version of `computesFun₂_branch`: to run a branch `body` that uses both of its +freshly-bound arguments, it suffices that `body` applied to the two fresh variables computes `out` +in the extended environment. This hides the `Computes.here`/length bookkeeping of `computesFun₂`. -/ +lemma computesFun₂_branch2 {x y : Value} {body : PB → PB → PB} {out : Value} + (h : ∀ ext, (body (PB.var (env.length + ext.length)) + (PB.var (env.length + ext.length + 1))).Computes (env ++ ext ++ [x, y]) out) : + computesFun₂ env x y body out := by + intro ext + simpa [List.length_append, Nat.add_assoc] using (h ext).here + /-- The code in `body` computes a function of one argument `x` and returns `out`. -/ def computesFun₁ (env : List Value) (x : Value) (body : PB → PB) (out : Value) : Prop := ∀ ext : List Value, ∃ t s, ProgSem (env ++ ext ++ [x]) (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1)) out t s +/-- To run a one-argument body on its freshly-bound argument, it suffices that `body` applied to +the fresh variable computes `out` in the extended environment. This hides the +`Computes.here`/length bookkeeping of `computesFun₁` (the one-argument analogue of +`computesFun₂_branch`). -/ +lemma computesFun₁_branch {x : Value} {body : PB → PB} {out : Value} + (h : ∀ ext, (body (PB.var (env.length + ext.length))).Computes (env ++ ext ++ [x]) out) : + computesFun₁ env x body out := by + intro ext + simpa [List.length_append, Nat.add_assoc] using (h ext).here + /-- `elim`, nil branch: `v` computes `[]`, so the empty branch `em` runs. -/ @[simp] lemma elim_nil_computes {v em : PB} {cs : PB → PB → PB} {out : Value} @@ -239,6 +269,81 @@ lemma app_fn_computes {body : PB → PB} {arg : PB} {dx out : Value} rw [hmap]; exact hb exact ⟨_, _, ProgSem.app ProgSem.fn ha (AppSem.mk hb')⟩ +/-- Resource-erased iteration of a `while_` loop body. `WhileComputes env body acc r` says that, +under any outer extension `ext`, repeatedly applying the loop-body closure (the closure produced by +`while_ _ body` at the current depth) starting from accumulator `acc` eventually yields `r`. + +This mirrors `WhileSem` at the builder level: it has the two introduction rules +`WhileComputes.halt` and `WhileComputes.step`, which together form the case analysis used in +inductive proofs about a `while_` loop. -/ +def WhileComputes (env : List Value) (body : PB → PB) (acc r : Data) : Prop := + ∀ ext : List Value, ∃ t s, + WhileSem + (.closure (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1)) + (env ++ ext)) + acc r t s + +/-- Halting case of `WhileComputes`: if the accumulator's head is empty, the loop stops with the +accumulator as result. Mirrors `WhileSem.halt`. -/ +lemma WhileComputes.halt {body : PB → PB} {acc : Data} + (h_stop : acc.asList.head?.getD (Data.l []) = Data.l []) : + WhileComputes env body acc acc := by + intro ext + exact ⟨_, _, WhileSem.halt h_stop⟩ + +/-- Stepping case of `WhileComputes`: if the accumulator's head is non-empty, applying the body to +`acc` yields `v` (this is exactly a `computesFun₁` for the body run on the freshly-bound argument), +and the loop continues from `v` to `r`, then the whole loop runs from `acc` to `r`. Mirrors +`WhileSem.step`. -/ +lemma WhileComputes.step {body : PB → PB} {acc v r : Data} + (h_cont : acc.asList.head?.getD (Data.l []) ≠ Data.l []) + (h_body : computesFun₁ env (.data acc) body (.data v)) + (h_rest : WhileComputes env body v r) : + WhileComputes env body acc r := by + intro ext + obtain ⟨tb, sb, hb⟩ := h_body ext + obtain ⟨tr, sr, hr⟩ := h_rest ext + exact ⟨_, _, WhileSem.step h_cont (AppSem.mk hb) hr⟩ + +/-- A `while_` loop computes `r`: evaluate `init` to the starting accumulator `acc`, then iterate +the body via `WhileComputes` from `acc` to `r`. The iteration hypothesis `h_loop` is established by +combining `WhileComputes.halt`/`WhileComputes.step`, typically inside an induction. -/ +lemma while_computes {init : PB} {body : PB → PB} {acc r : Data} + (h_init : Computes env init (.data acc)) + (h_loop : WhileComputes env body acc r) : + Computes env (PB.while_ init body) (.data r) := by + intro ext + obtain ⟨ti, si, hi⟩ := h_init ext + obtain ⟨tw, sw, hw⟩ := h_loop ext + simp only [PB.while_] + exact ⟨_, _, ProgSem.while_ hi ProgSem.fn hw⟩ + +/-- Recursion principle for building a `WhileComputes`. To show that the loop run from `acc` +produces `result acc`, supply, via a strictly-decreasing measure `μ`: +* `h_halt`: on a halting accumulator (empty head) the result is the accumulator itself; +* `h_step`: on a non-halting accumulator, the body computes a next accumulator `v` (a + `computesFun₁`), the measure strictly decreases (`μ v < μ acc`, guaranteeing termination), and the + loop result is preserved (`result v = result acc`). + +This packages the `WhileComputes.halt`/`WhileComputes.step` chaining into a single well-founded +recursion, so callers describe one step instead of unrolling the loop. -/ +theorem WhileComputes.rec' {body : PB → PB} (μ : Data → ℕ) (result : Data → Data) + (h_halt : ∀ acc : Data, + acc.asList.head?.getD (Data.l []) = Data.l [] → result acc = acc) + (h_step : ∀ acc : Data, acc.asList.head?.getD (Data.l []) ≠ Data.l [] → + ∃ v : Data, computesFun₁ env (.data acc) body (.data v) ∧ + μ v < μ acc ∧ result v = result acc) : + ∀ acc : Data, WhileComputes env body acc (result acc) := by + intro acc + generalize hn : μ acc = n + induction n using Nat.strong_induction_on generalizing acc with + | _ n ih => + by_cases h : acc.asList.head?.getD (Data.l []) = Data.l [] + · rw [h_halt acc h] + exact WhileComputes.halt h + · obtain ⟨v, hbody, hlt, hres⟩ := h_step acc h + rw [← hres] + exact WhileComputes.step h hbody (ih (μ v) (hn ▸ hlt) v rfl) ------------------- Resource Consumption ------------------------- diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 323ffd03d..6ef7c3e38 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -44,13 +44,13 @@ lemma encode_biTape (t : Turing.BiTape Symbol) : DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by simp [DataEncode.encode] -def bitape_write (t v : PB) : PB := PB.cons v t.tail +def bitapeWrite (t v : PB) : PB := PB.cons v t.tail lemma bitape_write_computes {p_tape p_sym : PB} {tape : BiTape Symbol} {sym : Option Symbol} (h_tape : p_tape.ComputesEnc env tape) (h_sym : p_sym.ComputesEnc env sym) : - (bitape_write p_tape p_sym).ComputesEnc env (tape.write sym) := by + (bitapeWrite p_tape p_sym).ComputesEnc env (tape.write sym) := by apply PB.cons_computes h_sym (PB.tail_computes h_tape) -- /-- Prepend an `Option` to the `StackTape` -/ @@ -207,165 +207,66 @@ lemma bitapeOptionMove_computes {p_t p_dir : PB} {t : BiTape Symbol} {d : Option Dir} (h_t : p_t.ComputesEnc env t) (h_dir : p_dir.ComputesEnc env d) : - (bitapeOptionMove p_t p_dir).ComputesEnc env (t.optionMove d) := by - cases d with - | none => exact PB.optionElim_computesEnc_none h_dir h_t - | some d => - refine PB.optionElim_computesEnc_some h_dir (PB.computesFun₂_branch (fun ext => ?_)) - exact bitapeMove_computes (h_t.extend_append ext _) (PB.var_computes_fresh ext _) - -instance (tm : SingleTapeTM Symbol) [DataEncode tm.State] : + (bitapeOptionMove p_t p_dir).ComputesEnc env (t.optionMove d) := + match d with + | none => PB.optionElim_computesEnc_none h_dir h_t + | some _ => + PB.optionElim_computesEnc_some h_dir (PB.computesFun₂_branch (fun ext => + bitapeMove_computes (h_t.extend ext |>.extend _) (PB.var_computes_fresh ext _))) + +instance [Inhabited Symbol] [Fintype Symbol] (tm : SingleTapeTM Symbol) [DataEncode tm.State] : DataEncode (Turing.SingleTapeTM.Cfg tm) where encode cfg := DataEncode.encode (cfg.state, cfg.BiTape) h_inj := by intro ⟨s₁, t₁⟩ ⟨s₂, t₂⟩ h have heq := DataEncode.h_inj h - simp at heq - obtain ⟨hs, ht⟩ := heq - cases hs; cases ht; rfl - --- Evaluate a function `f` at `arg` where the function is given as a graph. --- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise. -def eval_fun_graph (graph : PB) (arg : PB) : PB := - PB.fold - (fun acc x => - PB.optionElim acc - (PB.ifEq x.fst arg (PB.some x.snd) PB.empty) - fun _ => acc) - PB.empty graph - -/-- Semantic spec of `eval_fun_graph`: given an encoded graph (list of -`(α × β)`-pairs) and an encoded argument `a : α`, returns -`(graph.find? (·.1 = a)).map (·.2)`, i.e. `some y` for the first pair `(a, y)` -in the graph, else `none`. -/ -lemma eval_fun_graph_computes - {α β : Type} [DataEncode α] [DataEncode β] [DecidableEq α] - {env : List Data} {p_graph p_arg : PB} - {graph : List (α × β)} {a : α} - (h_graph : p_graph.computes_enc env graph) - (h_arg : p_arg.computes_enc env a) : - (eval_fun_graph p_graph p_arg).computes_enc env - ((graph.find? (fun p => p.1 = a)).map (·.2)) := by - -- The Lean-level step function for the fold. - let step : Option β → α × β → Option β := - fun acc x => acc.elim (if x.1 = a then some x.2 else none) (fun _ => acc) - -- Once the accumulator is `some _`, it stays `some _`. - have stays : ∀ (l : List (α × β)) (b : β), l.foldl step (some b) = some b := by - intro l b - induction l with - | nil => simp - | cons hd tl ih => simp [step, ih] - -- `foldl step none` matches `find?`-then-`map snd`. - have key : ∀ l : List (α × β), - l.foldl step none = (l.find? (fun p => p.1 = a)).map (·.2) := by - intro l - induction l with - | nil => simp - | cons hd tl ih => - simp only [List.foldl_cons, List.find?_cons] - by_cases h : hd.1 = a - · simp [step, h, stays] - · simp [step, h, ih] - rw [show (graph.find? (fun p => p.1 = a)).map (·.2) - = graph.foldl step none from (key graph).symm] - unfold eval_fun_graph - refine PB.fold_computes_enc (a := (none : Option β)) (f := step) - (by simp [PB.computes_enc, DataEncode.encode]) h_graph ?_ - intro acc x ext - rcases acc with _ | v - · -- acc = none: step none x = if x.1 = a then some x.2 else none - refine PB.optionElim_computes_none (α := β) - PB.elim_cons_head_var_computes ?_ - refine PB.ifEq_computes - (PB.fst_computes_enc PB.elim_cons_tail_var_computes) - (by simpa using h_arg.extend) ?_ ?_ - · intro h_enc - have h_eq : x.1 = a := DataEncode.h_inj h_enc - change PB.computes_enc _ _ (step none x) - simp only [step, Option.elim_none, if_pos h_eq] - exact PB.some_computes_enc - (PB.snd_computes_enc PB.elim_cons_tail_var_computes) - · intro h_enc - have h_ne : x.1 ≠ a := fun h => h_enc (by rw [h]) - simp [DataEncode.encode, step, h_ne] - · -- acc = some v: step (some v) x = some v - refine PB.optionElim_computes_some (α := β) - (PB.elim_cons_head_var_computes - (head := DataEncode.encode (some v : Option β))) ?_ - intro ext' - simpa [List.append_assoc, step] using PB.elim_cons_head_var_computes.extend - --- def graphOf {α β : Type} [Fintype α] (f : α → β) : List (α × β) := --- Fintype.elems.toList.map (fun a => (a, f a)) - -lemma eval_fun_graph_computes_of_fun - {α β : Type} [DataEncode α] [DataEncode β] [Fintype α] - {env : List Data} {p_graph p_arg : PB} - {a : α} - {f : α → β} - (h_graph : p_graph.computes_enc env (Fintype.elems.toList.map (fun a => (a, f a)))) - (h_arg : p_arg.computes_enc env a) : - (eval_fun_graph p_graph p_arg).head.computes_enc env (f a) := by - classical - have heq : ∀ (L : List α), a ∈ L → - ((L.map (fun a' => (a', f a'))).find? - (fun p => p.1 = a)).map (·.2) = some (f a) := by - intro L hmem - induction L with - | nil => exact absurd hmem (by simp) - | cons hd tl ih => grind - have h := eval_fun_graph_computes h_graph h_arg - rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h - simpa [DataEncode.encode, Data.asList] using PB.head_computes h - -def cfg_state (cfg : PB) : PB := cfg.fst -def cfg_bitape (cfg : PB) : PB := cfg.snd - -lemma cfg_state_computes [Inhabited Symbol] [Fintype Symbol] + grind + +def cfgState (cfg : PB) : PB := cfg.fst +def cfgBitape (cfg : PB) : PB := cfg.snd + +lemma cfgState_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} - (h : p.computes_enc env cfg) : - (cfg_state p).computes_enc env cfg.state := - PB.fst_computes_enc (a := (cfg.state, cfg.BiTape)) h + {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} + (h : p.ComputesEnc env cfg) : + (cfgState p).ComputesEnc env cfg.state := + PB.fst_ComputesEnc (a := (cfg.state, cfg.BiTape)) h lemma cfg_bitape_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {env : List Data} {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} - (h : p.computes_enc env cfg) : - (cfg_bitape p).computes_enc env cfg.BiTape := - PB.snd_computes_enc (a := (cfg.state, cfg.BiTape)) h + {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} + (h : p.ComputesEnc env cfg) : + (cfgBitape p).ComputesEnc env cfg.BiTape := + PB.snd_ComputesEnc (a := (cfg.state, cfg.BiTape)) h /-- Evaluate the transition function. Returns `((wr, dir), q')`. -- The return value is not wrapped inside an `Option` because the transition -- function is assumed to be total. -/ -def eval_tr (tr : PB) (q c : PB) : PB := - (eval_fun_graph (eval_fun_graph tr q).head c).head +def evalTr (tr : PB) (q c : PB) : PB := + (PB.evalFunGraph (PB.evalFunGraph tr q).head c).head instance : DataEncode (SingleTapeTM.Stmt Symbol) where encode stmt := DataEncode.encode (stmt.symbol, stmt.movement) h_inj := by intro ⟨s₁, m₁⟩ ⟨s₂, m₂⟩ h have heq := DataEncode.h_inj h - simp at heq - obtain ⟨hs, hm⟩ := heq - cases hs; cases hm; rfl + grind -lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State] - [DecidableEq State] [Fintype Symbol] - {env : List Data} {p_tr p_q p_c : PB} +lemma evalTr_computes {State : Type} [Fintype State] [DataEncode State] + [Fintype Symbol] + {p_tr p_q p_c : PB} {tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State} {q : State} {c : Option Symbol} - (h_tr : p_tr.computes_enc env + (h_tr : p_tr.ComputesEnc env ((Fintype.elems : Finset State).toList.map (fun q' : State => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' : Option Symbol => (c', tr q' c')))))) - (h_q : p_q.computes_enc env q) - (h_c : p_c.computes_enc env c) : - (eval_tr p_tr p_q p_c).computes_enc env (tr q c) := by - unfold eval_tr - exact eval_fun_graph_computes_of_fun (α := Option Symbol) (f := tr q) - (eval_fun_graph_computes_of_fun (α := State) (f := fun q' => + (h_q : p_q.ComputesEnc env q) + (h_c : p_c.ComputesEnc env c) : + (evalTr p_tr p_q p_c).ComputesEnc env (tr q c) := by + exact PB.evalFunGraph_Computes_of_fun (α := Option Symbol) (f := tr q) + (PB.evalFunGraph_Computes_of_fun (α := State) (f := fun q' => (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c'))) h_tr h_q) h_c @@ -382,104 +283,73 @@ lemma eval_tr_computes {State : Type} [Fintype State] [DataEncode State] -- -- and tape updated according to the Stmt -- | ⟨⟨wr, dir⟩, q''⟩ => some ⟨q'', (t.write wr).optionMove dir⟩ +def applyTrVal (trVal cfg : PB) : PB := + .some (PB.toPair + trVal.snd + (bitapeOptionMove (bitapeWrite (cfgBitape cfg) trVal.fst.fst) trVal.fst.snd)) + +lemma applyTrVal_computes + [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} + [DataEncode tm.State] + {p_trVal p_cfg : PB} + {cfg : tm.Cfg} + {trVal : SingleTapeTM.Stmt Symbol × Option tm.State} + (h_tr : p_trVal.ComputesEnc env trVal) + (h_cfg : p_cfg.ComputesEnc env cfg) : + (applyTrVal p_trVal p_cfg).ComputesEnc env + (Option.some + (⟨trVal.snd, (cfg.BiTape.write trVal.fst.1).optionMove trVal.fst.2⟩ : tm.Cfg)) := by + refine PB.some_ComputesEnc (PB.toPair_computesEnc (PB.snd_ComputesEnc h_tr) ?_) + refine bitapeOptionMove_computes (bitape_write_computes (cfg_bitape_computes h_cfg) ?_) ?_ + · exact PB.fst_ComputesEnc (a := (trVal.fst.1, trVal.fst.2)) (PB.fst_ComputesEnc h_tr) + · exact PB.snd_ComputesEnc (a := (trVal.fst.1, trVal.fst.2)) (PB.fst_ComputesEnc h_tr) + -- Compute the step function given a transition function (as its graph) and a configuration. -- Returns `Option Cfg` -def singleTapeTM_step (tr : PB) (cfg : PB) : PB := - PB.optionElim (cfg_state cfg) +def singleTapeTMStep (tr : PB) (cfg : PB) : PB := + PB.optionElim (cfgState cfg) PB.empty - (fun q' => PB.letIn (cfg_bitape cfg) (fun tape => - PB.letIn (eval_tr tr q' tape.head) (fun tr_val => - .some (to_pair - tr_val.snd - (bitape_optionMove (bitape_write tape tr_val.fst.fst) tr_val.fst.snd))))) - --- TODO for space and time bounds, we need to prove for singleTapeTM_step, than: --- for any `env`, --- 1) the size of the output is the size of `env` plus a constant (not with a linear factor!) --- 2) the time and space required is linear in the size of `env`. --- the problematic bits are that we don't know what `tr` and `cfg` do, they are programs, --- we cannot just look at their outputs --- What is the right condition for `tr` and `cfg`? - -lemma singleTapeTM_step_computes [Inhabited Symbol] [Fintype Symbol] - [DecidableEq Symbol] {tm : SingleTapeTM Symbol} - [DataEncode tm.State] [DecidableEq tm.State] - {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg} - (h_tr : p_tr.computes_enc env + (fun q' => applyTrVal (evalTr tr q' (cfgBitape cfg).head) cfg) + +lemma singleTapeTMStep_computes + [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} + [DataEncode tm.State] + {p_tr p_cfg : PB} {cfg : tm.Cfg} + (h_tr : p_tr.ComputesEnc env ((Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c')))))) - (h_cfg : p_cfg.computes_enc env cfg) : - (singleTapeTM_step p_tr p_cfg).computes_enc env (tm.step cfg) := by - unfold singleTapeTM_step + (h_cfg : p_cfg.ComputesEnc env cfg) : + (singleTapeTMStep p_tr p_cfg).ComputesEnc env (tm.step cfg) := by obtain ⟨state, t⟩ := cfg - match hst : state with + cases h : state with | none => - refine PB.optionElim_computes_none (cfg_state_computes h_cfg) ?_ - change PB.empty.computes_enc env (none : Option tm.Cfg) - simp [PB.computes_enc, DataEncode.encode] - | some q' => - refine PB.optionElim_computes_some (cfg_state_computes h_cfg) ?_ - intro ext1 - -- TODO letin makes this proof complicated. - -- Outer letIn: bind `tape := cfg_bitape p_cfg`, value `t`. - apply PB.letIn_computes_enc (v := t) - (by simpa [List.append_assoc] using cfg_bitape_computes h_cfg.extend) - intro ext2 - set env2 := env ++ ext1 ++ [DataEncode.encode q'] with env2_def - -- The slot for `q'` at depth `env.length + ext1.length`. - have h_q'_slot : PB.computes_enc - (env2 ++ ext2 ++ [DataEncode.encode t]) - (PB.atSlot (env.length + ext1.length)) q' := by - simpa [env2_def] using PB.atSlot_last_computes_enc.extend - -- The slot for `tape` at depth `env2.length + ext2.length`. - have h_tape_slot : PB.computes_enc - (env2 ++ ext2 ++ [DataEncode.encode t]) - (PB.atSlot (env2.length + ext2.length)) t := - PB.atSlot_last_computes_enc - apply PB.letIn_computes_enc - (eval_tr_computes - (by simpa [env2_def, List.append_assoc] using h_tr.extend) - h_q'_slot (bitape_head_computes h_tape_slot)) - intro ext3 - set env3 := env2 ++ ext2 ++ [DataEncode.encode t] with env3_def - set envS := env3 ++ ext3 ++ [DataEncode.encode (tm.tr q' t.head)] with envS_def - -- Re-derive tape slot at envS. - have h_tape_slot' : PB.computes_enc envS - (PB.atSlot (env2.length + ext2.length)) t := by - simpa [envS_def, env3_def, List.append_assoc] using - h_tape_slot.extend (ext := ext3 ++ [DataEncode.encode (tm.tr q' t.head)]) - -- Destructure the transition result. - rcases htr_eq : tm.tr q' t.head with ⟨⟨wr, dir⟩, q''⟩ - have h_trval : PB.computes_enc envS - (PB.atSlot (env3.length + ext3.length)) - (SingleTapeTM.Stmt.mk (Symbol := Symbol) wr dir, q'') := by - simp [envS_def, htr_eq] - unfold SingleTapeTM.step - simp only [htr_eq] - exact PB.some_computes_enc - (to_pair_computes - (PB.snd_computes_enc h_trval) - (bitape_optionMove_computes - (bitape_write_computes h_tape_slot' - (PB.fst_computes_enc (a := (wr, dir)) - (PB.fst_computes_enc h_trval))) - (PB.snd_computes_enc (a := (wr, dir)) - (PB.fst_computes_enc h_trval)))) + exact PB.optionElim_computesEnc_none + (by simpa [h] using (cfgState_computes h_cfg)) + PB.empty_computes + | some cfg => + refine PB.optionElim_computesEnc_some (by simpa [h] using (cfgState_computes h_cfg)) ?_ + apply PB.computesFun₂_branch + intro ext + refine applyTrVal_computes ?_ (h_cfg.extend ext |>.extend _) + refine evalTr_computes (h_tr.extend ext |>.extend _) (PB.var_computes_fresh ext _) ?_ + exact PB.head_computes (cfg_bitape_computes (h_cfg.extend ext |>.extend _)) def tm_main_loop (tr : PB) (cfg : PB) : PB := -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step` -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep -- the current `acc` (which has `state = none`, signalling halt to `while_`). PB.while_ cfg - (fun acc => PB.optionElim (singleTapeTM_step tr acc) acc (fun next => next)) + (fun acc => PB.optionElim (singleTapeTMStep tr acc) acc (fun next => next)) /-- The body of `tm_main_loop` computes one TM step (with `none` halt as fixed point). -/ private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] {env : List Data} {p_tr : PB} - (h_tr : p_tr.computes_enc env + (h_tr : p_tr.ComputesEnc env ((Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c')))))) @@ -491,13 +361,13 @@ private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol] intro ext set E := env ++ ext with E_def have hE_len : E.length = env.length + ext.length := by simp [E_def] - have h_acc : PB.computes_enc (E ++ [DataEncode.encode c]) + have h_acc : PB.ComputesEnc (E ++ [DataEncode.encode c]) (PB.atSlot E.length) c := by simpa using PB.atSlot_last_computes_enc (env := E) (ext := []) (a := c) have h_step_eval : - (singleTapeTM_step p_tr (PB.atSlot E.length)).computes_enc + (singleTapeTM_step p_tr (PB.atSlot E.length)).ComputesEnc (E ++ [DataEncode.encode c]) (tm.step c) := by - have h_tr_ext : PB.computes_enc (E ++ [DataEncode.encode c]) p_tr + have h_tr_ext : PB.ComputesEnc (E ++ [DataEncode.encode c]) p_tr ((Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c'))))) := by @@ -529,13 +399,13 @@ lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg} - (h_tr : p_tr.computes_enc env + (h_tr : p_tr.ComputesEnc env ((Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c')))))) - (h_cfg : p_cfg.computes_enc env cfg) + (h_cfg : p_cfg.ComputesEnc env cfg) (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) : - (tm_main_loop p_tr p_cfg).computes_enc env + (tm_main_loop p_tr p_cfg).ComputesEnc env ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map. set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def @@ -564,12 +434,12 @@ def reverse (x : PB) : PB := lemma reverse_computes {α : Type} [DataEncode α] {env : List Data} {p : PB} {l : List α} - (h : p.computes_enc env l) : - (reverse p).computes_enc env l.reverse := by + (h : p.ComputesEnc env l) : + (reverse p).ComputesEnc env l.reverse := by unfold reverse have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp rw [h_fold] - apply PB.fold_computes_enc (by simp [PB.computes_enc]) h + apply PB.fold_computes_enc (by simp [PB.ComputesEnc]) h -- TODO at this point, we should actually be able to just apply a combinator on the semantics -- of PB.cons intro acc el ext @@ -586,22 +456,22 @@ def list_map (x : PB) (f : PB → PB) : PB := lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β] {env : List Data} {p : PB} {l : List α} {f : PB → PB} {g : α → β} - (h : p.computes_enc env l) + (h : p.ComputesEnc env l) (hf : ∀ x : α, PB.computes_at_body₁_encoded env x f (g x)) : - (list_map p f).computes_enc env (l.map g) := by + (list_map p f).ComputesEnc env (l.map g) := by unfold list_map -- TODO simplify proof - have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).computes_enc + have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).ComputesEnc env (l.foldl (fun acc el => g el :: acc) []) := by apply PB.fold_computes_enc (a := ([] : List β)) (f := fun acc el => g el :: acc) - (by simp [PB.computes_enc, DataEncode.encode]) h + (by simp [PB.ComputesEnc, DataEncode.encode]) h intro acc el ext have h_acc : PB.computes_at (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by simpa using (PB.atSlot_last_computes (env := env) (ext := ext) (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el]) - have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).computes_enc + have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).ComputesEnc (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (g el) := by simpa [List.append_assoc] using hf el (ext ++ [DataEncode.encode acc]) simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_fel h_acc @@ -621,8 +491,8 @@ def list_reduceOption (x : PB) : PB := lemma list_reduceOption_computes {α : Type} [DataEncode α] {env : List Data} {p : PB} {l : List (Option α)} - (h : p.computes_enc env l) : - (list_reduceOption p).computes_enc env l.reduceOption := by + (h : p.ComputesEnc env l) : + (list_reduceOption p).ComputesEnc env l.reduceOption := by unfold list_reduceOption set step : List α → Option α → List α := fun acc el => match el with | none => acc | some y => y :: acc with step_def @@ -644,18 +514,18 @@ lemma list_reduceOption_computes {α : Type} [DataEncode α] simp [List.reduceOption] have h_fold : (PB.fold (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) PB.empty p - ).computes_enc env (l.foldl step []) := by + ).ComputesEnc env (l.foldl step []) := by apply PB.fold_computes_enc (a := ([] : List α)) (f := step) - (by simp [PB.computes_enc, DataEncode.encode]) h + (by simp [PB.ComputesEnc, DataEncode.encode]) h intro acc el ext - have h_el : (PB.atSlot (env.length + ext.length + 1)).computes_enc + have h_el : (PB.atSlot (env.length + ext.length + 1)).ComputesEnc (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) el := by - simpa [PB.computes_enc] using + simpa [PB.ComputesEnc] using (PB.atSlot_last_computes (ext := ext ++ [DataEncode.encode acc])).extend - have h_acc : (PB.atSlot (env.length + ext.length)).computes_enc + have h_acc : (PB.atSlot (env.length + ext.length)).ComputesEnc (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) acc := by - simpa [PB.computes_enc] using + simpa [PB.ComputesEnc] using (PB.atSlot_last_computes (env := env) (ext := ext) (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el]) cases el with @@ -699,8 +569,8 @@ def list_head_option (input : PB) : PB := lemma list_head_option_computes {α : Type} [DataEncode α] {env : List Data} {p : PB} {l : List α} - (h : p.computes_enc env l) : - (list_head_option p).computes_enc env l.head? := by + (h : p.ComputesEnc env l) : + (list_head_option p).ComputesEnc env l.head? := by cases l with | nil => apply PB.elim_nil_computes (em := PB.empty) @@ -718,19 +588,19 @@ def string_to_tape (input : PB) : PB := to_pair (list_head_option input) (to_pair .empty (list_map input.tail PB.some)) lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Symbol} - (h_input : p_input.computes_enc env input) : - (string_to_tape p_input).computes_enc env (BiTape.mk₁ input) := by - have h_tail : (PB.tail p_input).computes_enc env input.tail := by - simpa [PB.computes_enc, DataEncode.encode] using PB.tail_computes h_input - have h_map : (list_map (PB.tail p_input) PB.some).computes_enc env + (h_input : p_input.ComputesEnc env input) : + (string_to_tape p_input).ComputesEnc env (BiTape.mk₁ input) := by + have h_tail : (PB.tail p_input).ComputesEnc env input.tail := by + simpa [PB.ComputesEnc, DataEncode.encode] using PB.tail_computes h_input + have h_map : (list_map (PB.tail p_input) PB.some).ComputesEnc env (StackTape.map_some input.tail : Turing.StackTape Symbol) := by - simpa [PB.computes_enc, DataEncode.encode] + simpa [PB.ComputesEnc, DataEncode.encode] using list_map_computes h_tail (fun _ _ => by simpa [DataEncode.encode] using PB.cons_computes PB.atSlot_last_computes PB.empty_computes) - have h_empty : (PB.empty : PB).computes_enc env (∅ : Turing.StackTape Symbol) := by - simp [PB.computes_enc, DataEncode.encode] - simpa [PB.computes_enc, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape] + have h_empty : (PB.empty : PB).ComputesEnc env (∅ : Turing.StackTape Symbol) := by + simp [PB.ComputesEnc, DataEncode.encode] + simpa [PB.ComputesEnc, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape] using to_pair_computes (list_head_option_computes h_input) (to_pair_computes h_empty h_map) @@ -753,9 +623,9 @@ def universal_tm (input : PB) := lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {env : List Data} {p_q₀ p_input : PB} {input : List Symbol} - (h_q₀ : p_q₀.computes_enc env tm.q₀) - (h_input : p_input.computes_enc env input) : - (initial_config p_q₀ p_input).computes_enc env (tm.initCfg input) := by + (h_q₀ : p_q₀.ComputesEnc env tm.q₀) + (h_input : p_input.ComputesEnc env input) : + (initial_config p_q₀ p_input).ComputesEnc env (tm.initCfg input) := by -- `tm.initCfg input = ⟨some tm.q₀, BiTape.mk₁ input⟩`, and `encode` on `Cfg` goes -- through the `(state, BiTape)` pair, so this matches `to_pair`. exact to_pair_computes (PB.some_computes_enc h_q₀) (string_to_tape_computes h_input) @@ -763,17 +633,17 @@ lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol] lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {env : List Data} {p_cfg : PB} {cfg : tm.Cfg} - (h_cfg : p_cfg.computes_enc env cfg) : - (final_config_to_output p_cfg).computes_enc env + (h_cfg : p_cfg.ComputesEnc env cfg) : + (final_config_to_output p_cfg).ComputesEnc env (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := by unfold final_config_to_output - have h_BiTape : (p_cfg.snd).computes_enc env cfg.BiTape := + have h_BiTape : (p_cfg.snd).ComputesEnc env cfg.BiTape := PB.snd_computes_enc (a := (cfg.state, cfg.BiTape)) h_cfg have h_head := bitape_head_computes h_BiTape have h_right := bitape_right_computes h_BiTape -- The inner `cons` builds the encoding of `head :: right.toList` (a `List (Option Symbol)`), -- then `list_reduceOption` discards the blanks. - have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).computes_enc env + have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).ComputesEnc env (cfg.BiTape.head :: cfg.BiTape.right.toList) := by change PB.computes_at env _ (DataEncode.encode (cfg.BiTape.head :: cfg.BiTape.right.toList)) simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_head h_right @@ -782,7 +652,7 @@ lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol] lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] {env : List Data} {p_input : PB} {input : List Symbol} - (h_input : p_input.computes_enc env + (h_input : p_input.ComputesEnc env ((tm.q₀, (Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map @@ -790,7 +660,7 @@ lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Sym input)) (h_halts : ∃ n, ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none) : - (universal_tm p_input).computes_enc env + (universal_tm p_input).ComputesEnc env (let cfg := (fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg input) (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption) := by unfold universal_tm @@ -820,14 +690,14 @@ The encoded input has the shape `((tm.q₀, transitionTable), w)`, where theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] {env : List Data} {p_input : PB} {w w' : List Symbol} - (h_input : p_input.computes_enc env + (h_input : p_input.ComputesEnc env ((tm.q₀, (Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c'))))), w)) (h_out : tm.Outputs w w') : - (universal_tm p_input).computes_enc env w' := by + (universal_tm p_input).ComputesEnc env w' := by -- Lift `tm.step` to a total step function; halting states are fixed points. set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by @@ -958,13 +828,13 @@ theorem universal_tm_simulates_converse [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] {env : List Data} {p_input : PB} {w w' : List Symbol} - (h_input : p_input.computes_enc env + (h_input : p_input.ComputesEnc env ((tm.q₀, (Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c'))))), w)) - (h_out : (universal_tm p_input).computes_enc env w') : + (h_out : (universal_tm p_input).ComputesEnc env w') : ∃ n : ℕ, let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) cfg.state = none ∧ @@ -1052,13 +922,13 @@ private def Outputs' {Symbol : Type} [Inhabited Symbol] [Fintype Symbol] private theorem universal_tm_simulates_iff [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] {env : List Data} {p_input : PB} {w w' : List Symbol} - (h_input : p_input.computes_enc env + (h_input : p_input.ComputesEnc env ((tm.q₀, (Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c'))))), w)) : - Outputs' tm w w' ↔ (universal_tm p_input).computes_enc env w' := by + Outputs' tm w w' ↔ (universal_tm p_input).ComputesEnc env w' := by set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep_def have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by rintro ⟨_, _⟩ rfl; rfl diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index f4b032cc6..fa9860cfd 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -6,6 +6,9 @@ Authors: Christian Reitwiessner module +public import Mathlib.Data.Fintype.Defs +public import Mathlib.Data.Finset.Dedup +public import Mathlib.Data.List.ReduceOption public import Cslib.Computability.Machines.RTM.PB public import Cslib.Computability.Machines.RTM.DataEncode @@ -132,6 +135,10 @@ lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : (constantEnc a).ComputesEnc env a := by simp [ComputesEnc, constantEnc] + +------------- while semantics ------------------------ + + /-- `fold body init list`: left fold of `body` (taking `acc` then `el`) over `list`. Implemented with `while_` over a `[remaining, acc]` pair: the loop halts once `remaining` @@ -144,6 +151,142 @@ def fold (body : PB → PB → PB) (init list : PB) : PB := (fun el rest => toPair rest (body (PB.snd st) el)))) +-- Evaluate a function `f` at `arg` where the function is given as a graph (list of pairs). +-- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise. +def evalFunGraph (graph : PB) (arg : PB) : PB := + snd (PB.while_ + (toPair graph .empty) + (fun acc => .elim acc.fst + .empty -- cannot happen + fun pair rest => + ifEq pair.fst arg + (toPair .empty (PB.some pair.snd)) + (toPair rest .empty))) + +private def evalFunGraphInner : PB → PB → PB := + fun arg acc => .elim acc.fst + .empty -- cannot happen + fun pair rest => + ifEq pair.fst arg + (toPair .empty (PB.some pair.snd)) + (toPair rest .empty) + +private lemma evalFunGraphInner_computesFun₁ [DecidableEq α] + (arg : α) + {p_arg : PB} + (h_arg : p_arg.ComputesEnc env arg) + {graph : List (α × β)} + {x : α} + {y : β} : + computesFun₁ env + (.data (DataEncode.encode (((x, y) :: graph), (.none : Option β)))) + (evalFunGraphInner p_arg) + (.data (DataEncode.encode (if x == arg then + ([], Option.some y) + else + (graph, Option.none)))) := by + apply PB.computesFun₁_branch + intro ext + unfold evalFunGraphInner + refine PB.elim_cons_computes (PB.fst_ComputesEnc (PB.var_computes_fresh ext [])) ?_ + apply PB.computesFun₂_branch2 + intro ext2 + -- Names for the extended environment and its fresh bindings. + set acc := Value.data (DataEncode.encode (((x, y) :: graph), (.none : Option β))) + set pv := Value.data (DataEncode.encode (x, y)) with hpv + set rv := Value.data (Data.l (graph.map DataEncode.encode)) with hrv + -- `arg` (= `p_arg`) is still available after the environment grows. + have h_arg' := ((h_arg.extend ext).extend [acc]).extend ext2 |>.extend [pv, rv] + by_cases h : x = arg + · subst h + simp only [beq_self_eq_true, if_true] + exact ifeq_eq_computes + (fst_ComputesEnc (var_computes_fresh ext2 [rv])) + h_arg' + (toPair_computesEnc + (empty_computes) (some_ComputesEnc (snd_ComputesEnc (var_computes_fresh ext2 [rv])))) + · refine PB.ifeq_ne_computes (PB.fst_ComputesEnc (var_computes_fresh ext2 [rv])) h_arg' + (fun he => h (DataEncode.h_inj he)) ?_ + rw [if_neg (by simpa using h)] + exact PB.toPair_computesEnc + (var_computes_fresh' ext2 [pv, rv] (j := 1) (by simp)) (empty_computes) + + +/-- Semantic spec of `eval_fun_graph`: given an encoded graph (list of +`(α × β)`-pairs) and an encoded argument `a : α`, returns +`(graph.find? (·.1 = a)).map (·.2)`, i.e. `some y` for the first pair `(a, y)` +in the graph, else `none`. -/ +lemma evalFunGraph_computes + [DecidableEq α] + {p_graph p_arg : PB} + {graph : List (α × β)} + {a : α} + (h_graph : p_graph.ComputesEnc env graph) + (h_arg : p_arg.ComputesEnc env a) : + (evalFunGraph p_graph p_arg).ComputesEnc env + ((graph.find? (fun p => p.1 = a)).map (·.2)) := by + -- The loop iterates the body from `(g, none)` to `([], find-result)` for any remaining list `g`. + have h_loop : ∀ g : List (α × β), + WhileComputes env (evalFunGraphInner p_arg) + (DataEncode.encode (g, (none : Option β))) + (DataEncode.encode (([] : List (α × β)), + (g.find? (fun p => p.1 = a)).map (·.2))) := by + intro g + induction g with + | nil => + -- Empty remaining list: the loop halts immediately on the empty head. + apply WhileComputes.halt + simp [DataEncode.encode] + | cons hd tl ih => + obtain ⟨x, y⟩ := hd + by_cases h : x = a + · -- Match on the first element: body sets the result to `some y`, then the loop halts. + subst h + have hfind : (((x, y) :: tl).find? (fun p => p.1 = x)).map (·.2) = Option.some y := by + simp + rw [hfind] + have hb := evalFunGraphInner_computesFun₁ (env := env) x h_arg + (graph := tl) (x := x) (y := y) + simp only [beq_self_eq_true, if_true] at hb + refine WhileComputes.step ?_ hb ?_ + · simp [DataEncode.encode] + · apply WhileComputes.halt + simp [DataEncode.encode] + · -- No match on the first element: body drops it, keeps `none`, and recurses. + have hfind : (((x, y) :: tl).find? (fun p => p.1 = a)).map (·.2) + = (tl.find? (fun p => p.1 = a)).map (·.2) := by + simp [h] + rw [hfind] + have hb := evalFunGraphInner_computesFun₁ (env := env) a h_arg + (graph := tl) (x := x) (y := y) + rw [if_neg (show ¬ ((x == a) = true) by simpa using h)] at hb + exact WhileComputes.step (by simp [DataEncode.encode]) hb ih + -- Initial accumulator: `(graph, none)`. + have h_init : (toPair p_graph .empty).ComputesEnc env (graph, (none : Option β)) := + toPair_computesEnc h_graph (empty_computes) + exact snd_ComputesEnc (while_computes h_init (h_loop graph)) + + +lemma evalFunGraph_Computes_of_fun + [Fintype α] + {p_graph p_arg : PB} + {a : α} + {f : α → β} + (h_graph : p_graph.ComputesEnc env (Fintype.elems.toList.map (fun a => (a, f a)))) + (h_arg : p_arg.ComputesEnc env a) : + (PB.evalFunGraph p_graph p_arg).head.ComputesEnc env (f a) := by + classical + have heq : ∀ (L : List α), a ∈ L → + ((L.map (fun a' => (a', f a'))).find? + (fun p => p.1 = a)).map (·.2) = Option.some (f a) := by + intro L hmem + induction L with + | nil => exact absurd hmem (by simp) + | cons hd tl ih => grind + have h := PB.evalFunGraph_computes h_graph h_arg + rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h + apply PB.head_computes h + end PB From 34fb238d9749a09a6bf78fa923ec981ff841a8d4 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 11 Jun 2026 13:59:08 +0200 Subject: [PATCH 03/22] Simulate the main loop. --- .../Machines/RTM/DataEncode.lean | 11 +- Cslib/Computability/Machines/RTM/Prog.lean | 6 +- .../Machines/RTM/TMSimulator.lean | 668 ++---------------- 3 files changed, 74 insertions(+), 611 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/DataEncode.lean b/Cslib/Computability/Machines/RTM/DataEncode.lean index b4c601213..ff809f4b4 100644 --- a/Cslib/Computability/Machines/RTM/DataEncode.lean +++ b/Cslib/Computability/Machines/RTM/DataEncode.lean @@ -34,9 +34,7 @@ instance (α : Type) [DataEncode α] : DataEncode (List α) where encode xs := Data.l (xs.map DataEncode.encode) h_inj := by intro a b h - have h' : a.map (DataEncode.encode : α → Data) = b.map DataEncode.encode := - Data.l.inj h - exact List.map_injective_iff.mpr DataEncode.h_inj h' + exact List.map_injective_iff.mpr DataEncode.h_inj (Data.l.inj h) @[simp, scoped grind =] lemma DataEncode_list_nil {α : Type} [DataEncode α] : @@ -59,8 +57,7 @@ instance (α : Type) [DataEncode α] : DataEncode (Option α) where | some x => Data.l [DataEncode.encode x] h_inj := by intro a b h - cases a <;> cases b <;> simp_all - exact DataEncode.h_inj h + grind [DataEncode.h_inj] @[simp] lemma DataEncode_Option_empty {α : Type} [DataEncode α] (x : Option α) : @@ -71,8 +68,7 @@ instance (α β : Type) [DataEncode α] [DataEncode β] : DataEncode (α × β) encode := fun (a, b) => Data.l [DataEncode.encode a, DataEncode.encode b] h_inj := by intro ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h - simp at h - exact Prod.mk.injEq .. |>.mpr ⟨DataEncode.h_inj h.1, DataEncode.h_inj h.2⟩ + grind [DataEncode.h_inj] lemma DataEncode_pair {α β : Type} [DataEncode α] [DataEncode β] (a : α) (b : β) : DataEncode.encode (a, b) = Data.l [DataEncode.encode a, DataEncode.encode b] := by @@ -83,7 +79,6 @@ instance : DataEncode ℕ where h_inj := by intro a b h have hb : a.bits = b.bits := DataEncode.h_inj h - -- Reconstruct a from a.bits via binaryRec. have hrec : ∀ n : ℕ, n.bits.foldr (fun b acc => Nat.bit b acc) 0 = n := by intro n induction n using Nat.binaryRec' with diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index 6d1a1d79a..6132cfd15 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -82,7 +82,11 @@ inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop ProgSem σ (.elim val emp cs) r (t_v + t_emp) (max s_v s_emp) /-- `elim`, cons branch: `v` destructures to `hd :: tl`; evaluate the function `cs` to a closure and apply it first to `hd` and then to `tl` (so `cs` is a curried - two-argument function). -/ + two-argument function). + TODO: We could syntactically require that hte `cs` argument always has the form + `.fn .fn ...`, then we could change the cost function so that we do not need to charge + for creating the closure (and the same for all similar constructs). + -/ | elim_cons (h_v : ProgSem σ val (.data (Data.l (hd :: tl))) t_v s_v) (h_cs : ProgSem σ cs cv t_cs s_cs) diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 6ef7c3e38..6932f04ea 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -316,7 +316,8 @@ lemma singleTapeTMStep_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {p_tr p_cfg : PB} {cfg : tm.Cfg} + {p_tr p_cfg : PB} + {cfg : tm.Cfg} (h_tr : p_tr.ComputesEnc env ((Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map @@ -337,622 +338,85 @@ lemma singleTapeTMStep_computes refine evalTr_computes (h_tr.extend ext |>.extend _) (PB.var_computes_fresh ext _) ?_ exact PB.head_computes (cfg_bitape_computes (h_cfg.extend ext |>.extend _)) -def tm_main_loop (tr : PB) (cfg : PB) : PB := +def tmMainLoop (tr : PB) (cfg : PB) : PB := -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step` -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep -- the current `acc` (which has `state = none`, signalling halt to `while_`). PB.while_ cfg (fun acc => PB.optionElim (singleTapeTMStep tr acc) acc (fun next => next)) -/-- The body of `tm_main_loop` computes one TM step (with `none` halt as fixed point). -/ -private lemma tm_main_loop_body_computes [Inhabited Symbol] [Fintype Symbol] - [DecidableEq Symbol] {tm : SingleTapeTM Symbol} - [DataEncode tm.State] [DecidableEq tm.State] - {env : List Data} {p_tr : PB} - (h_tr : p_tr.ComputesEnc env - ((Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c')))))) - (c : tm.Cfg) : - PB.computes_at_body₁ env (DataEncode.encode c) - (fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next)) - (DataEncode.encode ((tm.step c).getD c)) := by - set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def - intro ext - set E := env ++ ext with E_def - have hE_len : E.length = env.length + ext.length := by simp [E_def] - have h_acc : PB.ComputesEnc (E ++ [DataEncode.encode c]) - (PB.atSlot E.length) c := by - simpa using PB.atSlot_last_computes_enc (env := E) (ext := []) (a := c) - have h_step_eval : - (singleTapeTM_step p_tr (PB.atSlot E.length)).ComputesEnc - (E ++ [DataEncode.encode c]) (tm.step c) := by - have h_tr_ext : PB.ComputesEnc (E ++ [DataEncode.encode c]) p_tr - ((Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c'))))) := by - have := h_tr.extend (ext := ext ++ [DataEncode.encode c]) - simpa [E_def, List.append_assoc] using this - exact singleTapeTM_step_computes h_tr_ext h_acc - change PB.computes_at (E ++ [DataEncode.encode c]) - (PB.optionElim (singleTapeTM_step p_tr (PB.atSlot (env.length + ext.length))) - (PB.atSlot (env.length + ext.length)) - (fun next => next)) (DataEncode.encode (step c)) - rw [← hE_len] - cases hstep_c : tm.step c with - | none => - rw [show step c = c from by simp only [step_def]; rw [hstep_c]; rfl] - exact PB.optionElim_computes_none (hstep_c ▸ h_step_eval) h_acc - | some next => - rw [show step c = next from by simp only [step_def]; rw [hstep_c]; rfl] - refine PB.optionElim_computes_some (hstep_c ▸ h_step_eval) ?_ - intro ext' - simpa using PB.atSlot_last_computes_enc - (env := E ++ [DataEncode.encode c]) (ext := ext') (a := next) - -/-- Spec for `tm_main_loop`: assuming the TM eventually halts when started from -`cfg` (witnessed by some `n` after which iterating `tm.step` reaches a `none` -state), the loop computes the configuration obtained after the *minimal* such -number of steps. Here `tm.step` is lifted to `tm.Cfg → tm.Cfg` by treating the -halt result `none` as a fixed point via `Option.getD`. -/ -lemma tm_main_loop_computes [Inhabited Symbol] [Fintype Symbol] - [DecidableEq Symbol] {tm : SingleTapeTM Symbol} - [DataEncode tm.State] [DecidableEq tm.State] - {env : List Data} {p_tr p_cfg : PB} {cfg : tm.Cfg} +partial def simulateTM + [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} + (cfg : tm.Cfg) := + match tm.step cfg with + | none => cfg + | some cfg' => simulateTM cfg' + +lemma tmMainLoop_computes + [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} + [DataEncode tm.State] + {p_tr p_cfg : PB} + {cfg : tm.Cfg} (h_tr : p_tr.ComputesEnc env ((Fintype.elems : Finset tm.State).toList.map (fun q' => (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c')))))) (h_cfg : p_cfg.ComputesEnc env cfg) (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) : - (tm_main_loop p_tr p_cfg).ComputesEnc env + (tmMainLoop p_tr p_cfg).ComputesEnc env ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by - -- Lift `tm.step` to a total `tm.Cfg → tm.Cfg` map. + -- Totalise `tm.step`; halting states become fixed points. set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def - -- `headD` of an encoded `Cfg` is empty iff the state is `none`. - have headD_iff : ∀ c : tm.Cfg, - (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by - rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList] - -- Translate the halting hypothesis through the iff. - have h_halts' : ∃ n, (DataEncode.encode (step^[n] cfg)).asList.headD (Data.l []) = Data.l [] := - h_halts.imp fun _ h => (headD_iff _).mpr h - have find_eq : Nat.find h_halts' = Nat.find h_halts := - le_antisymm - (Nat.find_le ((headD_iff _).mpr (Nat.find_spec h_halts))) - (Nat.find_le ((headD_iff _).mp (Nat.find_spec h_halts'))) - -- Reduce to a `while_` spec call. - change PB.computes_at env (tm_main_loop p_tr p_cfg) - (DataEncode.encode (step^[Nat.find h_halts] cfg)) - rw [← find_eq] - unfold tm_main_loop - exact PB.while_computes_iter (env := env) (p_init := p_cfg) - (body := fun acc => PB.optionElim (singleTapeTM_step p_tr acc) acc (fun next => next)) - step cfg h_cfg (tm_main_loop_body_computes h_tr) h_halts' - -def reverse (x : PB) : PB := - PB.fold (fun acc el => PB.cons el acc) PB.empty x - -lemma reverse_computes {α : Type} [DataEncode α] - {env : List Data} {p : PB} {l : List α} - (h : p.ComputesEnc env l) : - (reverse p).ComputesEnc env l.reverse := by - unfold reverse - have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp - rw [h_fold] - apply PB.fold_computes_enc (by simp [PB.ComputesEnc]) h - -- TODO at this point, we should actually be able to just apply a combinator on the semantics - -- of PB.cons - intro acc el ext - have h_el : PB.computes_at - (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) - (PB.atSlot (env.length + ext.length + 1)) (DataEncode.encode el) := by - simpa using (PB.atSlot_last_computes (ext := ext ++ [DataEncode.encode acc])).extend - simpa [DataEncode.encode, Data.asList] using - PB.cons_computes h_el (by simpa using PB.atSlot_last_computes.extend) - -def list_map (x : PB) (f : PB → PB) : PB := - reverse (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty x) - -lemma list_map_computes {α β : Type} [DataEncode α] [DataEncode β] - {env : List Data} {p : PB} {l : List α} - {f : PB → PB} {g : α → β} - (h : p.ComputesEnc env l) - (hf : ∀ x : α, PB.computes_at_body₁_encoded env x f (g x)) : - (list_map p f).ComputesEnc env (l.map g) := by - unfold list_map - -- TODO simplify proof - have h_fold : (PB.fold (fun acc el => PB.cons (f el) acc) PB.empty p).ComputesEnc - env (l.foldl (fun acc el => g el :: acc) []) := by - apply PB.fold_computes_enc (a := ([] : List β)) (f := fun acc el => g el :: acc) - (by simp [PB.ComputesEnc, DataEncode.encode]) h - intro acc el ext - have h_acc : PB.computes_at - (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) - (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by - simpa using (PB.atSlot_last_computes (env := env) (ext := ext) - (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el]) - have h_fel : (f (PB.atSlot (env.length + ext.length + 1))).ComputesEnc - (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) (g el) := by - simpa [List.append_assoc] using hf el (ext ++ [DataEncode.encode acc]) - simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_fel h_acc - have h_rev := reverse_computes h_fold - have h_eq : (l.foldl (fun acc el => g el :: acc) []).reverse = l.map g := by - rw [show l.foldl (fun acc el => g el :: acc) [] - = (l.map g).foldl (fun acc el => el :: acc) [] from - (List.foldl_map (f := g) (g := fun acc el => el :: acc) (l := l) (init := [])).symm] - simp - rwa [h_eq] at h_rev - -/-- Discards the `none` elements of a list of options, keeping the `some` payloads. -/ -def list_reduceOption (x : PB) : PB := - reverse (PB.fold - (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) - PB.empty x) - -lemma list_reduceOption_computes {α : Type} [DataEncode α] - {env : List Data} {p : PB} {l : List (Option α)} - (h : p.ComputesEnc env l) : - (list_reduceOption p).ComputesEnc env l.reduceOption := by - unfold list_reduceOption - set step : List α → Option α → List α := - fun acc el => match el with | none => acc | some y => y :: acc with step_def - -- Convert `reduceOption` to the foldl form of `step` (with reversed accumulator). We need - -- this generalized over the initial accumulator so the induction goes through. - have h_eq : ∀ (xs : List (Option α)) (init : List α), - (xs.foldl step init).reverse = init.reverse ++ xs.reduceOption := by - intro xs - induction xs with - | nil => intro init; simp [List.reduceOption] - | cons hd tl ih => - intro init - cases hd with - | none => simpa [step_def] using ih init - | some y => - have h1 : List.foldl step init (some y :: tl) = List.foldl step (y :: init) tl := by - simp [step_def] - rw [h1, ih (y :: init)] - simp [List.reduceOption] - have h_fold : (PB.fold - (fun acc el => PB.optionElim el acc (fun y => PB.cons y acc)) PB.empty p - ).ComputesEnc env (l.foldl step []) := by - apply PB.fold_computes_enc - (a := ([] : List α)) (f := step) - (by simp [PB.ComputesEnc, DataEncode.encode]) h - intro acc el ext - have h_el : (PB.atSlot (env.length + ext.length + 1)).ComputesEnc - (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) el := by - simpa [PB.ComputesEnc] using - (PB.atSlot_last_computes (ext := ext ++ [DataEncode.encode acc])).extend - have h_acc : (PB.atSlot (env.length + ext.length)).ComputesEnc - (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode el]) acc := by - simpa [PB.ComputesEnc] using - (PB.atSlot_last_computes (env := env) (ext := ext) - (d := DataEncode.encode acc)).extend (ext := [DataEncode.encode el]) - cases el with + have halt_fix : ∀ c : tm.Cfg, c.state = none → step c = c := by + intro c hc + obtain ⟨s, t⟩ := c + cases s with + | none => simp [step_def] + | some q => simp at hc + -- The head of an encoded `Cfg` is empty iff its state is `none` (the loop's halt condition). + have headEmpty_iff : ∀ c : tm.Cfg, + (DataEncode.encode c).asList.head?.getD (Data.l []) = Data.l [] ↔ c.state = none := by + rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode] + -- One iteration of the loop body computes `step c`. + have body_computes : ∀ c : tm.Cfg, + PB.computesFun₁ env (.data (DataEncode.encode c)) + (fun acc => PB.optionElim (singleTapeTMStep p_tr acc) acc (fun next => next)) + (.data (DataEncode.encode (step c))) := by + intro c + apply PB.computesFun₁_branch + intro ext + have h_acc : (PB.var (env.length + ext.length)).ComputesEnc _ c := PB.var_computes_fresh ext [] + have h_step := singleTapeTMStep_computes (h_tr.extend ext |>.extend _) h_acc + cases hsc : tm.step c with | none => - simpa [step_def] using - PB.optionElim_computes_none (α := α) h_el h_acc - | some y => - refine PB.optionElim_computes_some (α := α) h_el ?_ - intro ext' - -- Inside someCase, the bound `y` lives at slot - -- `env.length + ext.length + 2 + ext'.length`; `acc` is still at `env.length + ext.length`. - set ext_inner := - ext ++ [DataEncode.encode acc, DataEncode.encode (some y)] ++ ext' with ext_inner_def - have hlen : ext_inner.length = ext.length + 2 + ext'.length := by - simp [ext_inner_def, Nat.add_comm, Nat.add_left_comm] - have h_y : - PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y]) - (PB.atSlot (env.length + ext.length + 2 + ext'.length)) - (DataEncode.encode y) := by - have h := PB.atSlot_last_computes - (env := env) (ext := ext_inner) (d := DataEncode.encode y) - rw [hlen] at h - convert h using 2 - omega - have h_acc' : - PB.computes_at (env ++ ext_inner ++ [DataEncode.encode y]) - (PB.atSlot (env.length + ext.length)) (DataEncode.encode acc) := by - have h := (h_acc : - PB.computes_at (env ++ ext ++ [DataEncode.encode acc, DataEncode.encode (some y)]) - _ (DataEncode.encode acc)).extend (ext := ext' ++ [DataEncode.encode y]) - simpa [ext_inner_def, List.append_assoc] using h - have h_cons := PB.cons_computes h_y h_acc' - simp only [ext_inner_def] at h_cons - simpa [step_def, DataEncode.encode, Data.asList, List.append_assoc] using h_cons - have h_rev := reverse_computes h_fold - have h_eq₀ : (l.foldl step []).reverse = l.reduceOption := by simpa using h_eq l [] - rwa [h_eq₀] at h_rev - -def list_head_option (input : PB) : PB := - PB.elim input PB.empty (fun hd _tl => PB.some hd) - -lemma list_head_option_computes {α : Type} [DataEncode α] - {env : List Data} {p : PB} {l : List α} - (h : p.ComputesEnc env l) : - (list_head_option p).ComputesEnc env l.head? := by - cases l with - | nil => - apply PB.elim_nil_computes (em := PB.empty) - · simpa [DataEncode.encode] using h - · simp [DataEncode.encode] - | cons hd tl => - apply PB.elim_cons_computes (head := DataEncode.encode hd) - (tail := tl.map DataEncode.encode) - · simpa [DataEncode.encode] using h - · intro ext - simpa [DataEncode.encode] using - PB.cons_computes PB.elim_cons_head_var_computes PB.empty_computes - -def string_to_tape (input : PB) : PB := - to_pair (list_head_option input) (to_pair .empty (list_map input.tail PB.some)) - -lemma string_to_tape_computes {env : List Data} {p_input : PB} {input : List Symbol} - (h_input : p_input.ComputesEnc env input) : - (string_to_tape p_input).ComputesEnc env (BiTape.mk₁ input) := by - have h_tail : (PB.tail p_input).ComputesEnc env input.tail := by - simpa [PB.ComputesEnc, DataEncode.encode] using PB.tail_computes h_input - have h_map : (list_map (PB.tail p_input) PB.some).ComputesEnc env - (StackTape.map_some input.tail : Turing.StackTape Symbol) := by - simpa [PB.ComputesEnc, DataEncode.encode] - using list_map_computes h_tail (fun _ _ => by - simpa [DataEncode.encode] using - PB.cons_computes PB.atSlot_last_computes PB.empty_computes) - have h_empty : (PB.empty : PB).ComputesEnc env (∅ : Turing.StackTape Symbol) := by - simp [PB.ComputesEnc, DataEncode.encode] - simpa [PB.ComputesEnc, encode_biTape, BiTape.mk₁, DataEncode_pair, string_to_tape] - using to_pair_computes (list_head_option_computes h_input) - (to_pair_computes h_empty h_map) - - -def initial_config (q₀ : PB) (input : PB) : PB := - to_pair (PB.some q₀) (string_to_tape input) - -/-- Turn the final config to an output, by taking the head and the right part of the tape - and discarding the blank (`none`) cells. -/ -def final_config_to_output (cfg : PB) : PB := - list_reduceOption (PB.cons (bitapeHead cfg.snd) (bitapeRight cfg.snd)) - -/-- Implements a universal Single-Tape TM, assuming that the input contains the following: -((initialState, transitionFunction), input). -If it terminates, the output is the tape contents under the head and to its right. -/ -def universal_tm (input : PB) := - final_config_to_output - (tm_main_loop input.fst.snd (initial_config input.fst.fst input.snd)) - -lemma initial_config_computes [Inhabited Symbol] [Fintype Symbol] - {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {env : List Data} {p_q₀ p_input : PB} {input : List Symbol} - (h_q₀ : p_q₀.ComputesEnc env tm.q₀) - (h_input : p_input.ComputesEnc env input) : - (initial_config p_q₀ p_input).ComputesEnc env (tm.initCfg input) := by - -- `tm.initCfg input = ⟨some tm.q₀, BiTape.mk₁ input⟩`, and `encode` on `Cfg` goes - -- through the `(state, BiTape)` pair, so this matches `to_pair`. - exact to_pair_computes (PB.some_computes_enc h_q₀) (string_to_tape_computes h_input) - -lemma final_config_to_output_computes [Inhabited Symbol] [Fintype Symbol] - {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {env : List Data} {p_cfg : PB} {cfg : tm.Cfg} - (h_cfg : p_cfg.ComputesEnc env cfg) : - (final_config_to_output p_cfg).ComputesEnc env - (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := by - unfold final_config_to_output - have h_BiTape : (p_cfg.snd).ComputesEnc env cfg.BiTape := - PB.snd_computes_enc (a := (cfg.state, cfg.BiTape)) h_cfg - have h_head := bitape_head_computes h_BiTape - have h_right := bitape_right_computes h_BiTape - -- The inner `cons` builds the encoding of `head :: right.toList` (a `List (Option Symbol)`), - -- then `list_reduceOption` discards the blanks. - have h_list : (PB.cons (bitape_head p_cfg.snd) (bitape_right p_cfg.snd)).ComputesEnc env - (cfg.BiTape.head :: cfg.BiTape.right.toList) := by - change PB.computes_at env _ (DataEncode.encode (cfg.BiTape.head :: cfg.BiTape.right.toList)) - simpa [DataEncode.encode, Data.asList] using PB.cons_computes h_head h_right - exact list_reduceOption_computes h_list - -lemma universal_tm_computes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] - {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] - {env : List Data} {p_input : PB} {input : List Symbol} - (h_input : p_input.ComputesEnc env - ((tm.q₀, - (Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c'))))), - input)) - (h_halts : ∃ n, - ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none) : - (universal_tm p_input).ComputesEnc env - (let cfg := (fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg input) - (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption) := by - unfold universal_tm - have h_fst := PB.fst_computes_enc h_input - have h_q₀ := PB.fst_computes_enc h_fst - have h_tr := PB.snd_computes_enc h_fst - have h_inp := PB.snd_computes_enc h_input - exact final_config_to_output_computes - (tm_main_loop_computes h_tr (initial_config_computes h_q₀ h_inp) h_halts) - -/-- The output of reading the tape from `BiTape.mk₁ l` (head + right, then discarding -blanks) recovers `l`. -/ -private lemma reduceOption_mk₁_tape {Symbol : Type} (l : List Symbol) : - ((BiTape.mk₁ l).head :: (BiTape.mk₁ l).right.toList).reduceOption = l := by - have h : ∀ xs : List Symbol, (xs.map Option.some).reduceOption = xs := fun xs => by - induction xs with - | nil => rfl - | cons _ _ ih => simp [ih] - cases l <;> simp [BiTape.mk₁, Turing.StackTape.map_some_toList, h] - -/-- For a `SingleTapeTM` `tm` and any input `w`, if `tm` outputs `w'` on input `w`, -then the universal Turing machine `universal_tm`, when given an encoding of `tm` -together with `w`, computes `w'`. - -The encoded input has the shape `((tm.q₀, transitionTable), w)`, where -`transitionTable` enumerates `tm.tr` over all `(state, head symbol)` pairs. -/ -theorem universal_tm_simulates [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] - {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] - {env : List Data} {p_input : PB} {w w' : List Symbol} - (h_input : p_input.ComputesEnc env - ((tm.q₀, - (Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c'))))), - w)) - (h_out : tm.Outputs w w') : - (universal_tm p_input).ComputesEnc env w' := by - -- Lift `tm.step` to a total step function; halting states are fixed points. - set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep - have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by - rintro ⟨_, _⟩ rfl; rfl - have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by - intro k _ hc - induction k with - | zero => rfl - | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc] - -- Convert `ReflTransGen` into an explicit step count via tail-induction. - obtain ⟨n, hn⟩ : ∃ n, step^[n] (tm.initCfg w) = tm.haltCfg w' := by - suffices h : ∀ {c c' : tm.Cfg}, Relation.ReflTransGen tm.TransitionRelation c c' → - ∃ n, step^[n] c = c' from h h_out - intro c c' hrel - induction hrel with - | refl => exact ⟨0, rfl⟩ - | tail _ h' ih => - obtain ⟨n, hn⟩ := ih - refine ⟨n + 1, ?_⟩ - rw [Function.iterate_succ_apply', hn] - change (tm.step _).getD _ = _ - rw [h'] - rfl - -- The halting hypothesis required by `universal_tm_computes`. - have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, by rw [hn]; rfl⟩ - -- Determinism + stationarity: `Nat.find` of the halt index also reaches `haltCfg w'`. - have h_find : step^[Nat.find h_halts] (tm.initCfg w) = tm.haltCfg w' := by - have h_le : Nat.find h_halts ≤ n := Nat.find_le (by rw [hn]; rfl) - have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts) - rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le, hn] at h_iter - exact h_iter.symm - -- Conclude via `universal_tm_computes`. - have h := universal_tm_computes (tm := tm) h_input h_halts - rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) = - tm.haltCfg w' from h_find] at h - simpa [SingleTapeTM.haltCfg, reduceOption_mk₁_tape] using h - -/-- Bubble-down for `universal_tm`: if `universal_tm p_input` produces some encoded -output at `env`, then the inner `tm_main_loop` also produces some value at `env`. -/ -private lemma universal_tm_eval_some_imp_loop_eval_some - {p_input : PB} {env : List Data} {d : Data} - (h : (universal_tm p_input env.length).eval env = .some d) : - ∃ d', (tm_main_loop p_input.fst.snd - (initial_config p_input.fst.fst p_input.snd) env.length).eval env = .some d' := by - -- We chase `.some` through every `Part.bind` in the call chain. Each `bind` is - -- introduced by a `Prog` constructor in `meteredEval`; if the outer eval is - -- `.some`, the bound subexpression must be `.some` too. - set n := env.length with hn - set mloop : Prog := tm_main_loop p_input.fst.snd - (initial_config p_input.fst.fst p_input.snd) n with mloop_def - -- Bubble through `cons`: if `Prog.cons a b` evals to some, both subterms do. - have bd_cons : ∀ {a b : Prog} {env d}, - (Prog.cons a b).eval env = .some d → - (∃ da, a.eval env = .some da) ∧ (∃ db, b.eval env = .some db) := by - intro a b env d h - rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h - obtain ⟨⟨d', _, _⟩, hm, _⟩ := h - unfold Prog.meteredEval at hm - simp only [bind, Part.mem_bind_iff] at hm - obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm - obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest - refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩ - · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩ - · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩ - -- Bubble through `elim`: if `Prog.elim v em cs` evals to some, then `v` does. - have bd_elim : ∀ {v em cs : Prog} {env d}, - (Prog.elim v em cs).eval env = .some d → ∃ dv, v.eval env = .some dv := by - intro v em cs env d h - rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h - obtain ⟨⟨d', _, _⟩, hm, _⟩ := h - unfold Prog.meteredEval at hm - simp only [bind, Part.mem_bind_iff] at hm - obtain ⟨⟨ah, _, _⟩, ha, _⟩ := hm - refine ⟨ah, ?_⟩ - rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩ - -- Bubble through `fold`: if `Prog.fold body init list` evals to some, then `init` - -- and `list` do. - have bd_fold : ∀ {body init list : Prog} {env d}, - (Prog.fold body init list).eval env = .some d → - (∃ di, init.eval env = .some di) ∧ (∃ dl, list.eval env = .some dl) := by - intro body init list env d h - rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff] at h - obtain ⟨⟨d', _, _⟩, hm, _⟩ := h - unfold Prog.meteredEval at hm - simp only [bind, Part.mem_bind_iff] at hm - obtain ⟨⟨ah, _, _⟩, ha, hrest⟩ := hm - obtain ⟨⟨bh, _, _⟩, hb, _⟩ := hrest - refine ⟨⟨ah, ?_⟩, ⟨bh, ?_⟩⟩ - · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, ha, rfl⟩ - · rw [Prog.eval, Part.eq_some_iff, Part.mem_map_iff]; exact ⟨_, hb, rfl⟩ - -- Now unfold `universal_tm = final_config_to_output (...)`, - -- `final_config_to_output cfg = list_reduceOption (PB.cons (bitape_head cfg.snd) (bitape_right cfg.snd))`, - -- `list_reduceOption = reverse (PB.fold ...)`, `reverse = PB.fold ...`. - -- At each step we bubble down through the relevant `Prog` constructor. - -- `universal_tm p_input` reduces to a `list_reduceOption (...)` whose innermost - -- list expression depends on `mloop`. Bubble through two `PB.fold`s, then through - -- `PB.cons`, then through `bitape_head/right` (which are `head`/`tail` chains, i.e. `elim`s) - -- to extract a `some` evaluation for `mloop`. - change (final_config_to_output (tm_main_loop p_input.fst.snd - (initial_config p_input.fst.fst p_input.snd)) n).eval env = .some d at h - unfold final_config_to_output list_reduceOption reverse at h - -- Two folds → cons → bitape_head/right (each `head`/`tail`/`fst`/`snd` is `elim` chain) - obtain ⟨_, ⟨d1, h1⟩⟩ := bd_fold h - obtain ⟨_, ⟨d2, h2⟩⟩ := bd_fold h1 - -- h2 : (PB.cons (bitape_head mloop'.snd) (bitape_right mloop'.snd)) n .eval env = some d2 - -- where mloop' = tm_main_loop ... - change (Prog.cons _ _).eval env = .some d2 at h2 - obtain ⟨⟨d3, h3⟩, _⟩ := bd_cons h2 - -- h3 : bitape_head (...).snd evaluates to some - -- bitape_head t = t.fst = head t = elim t empty (fun ...) - -- bitape_head (mloop').snd = head (head (tail mloop')) - change (Prog.elim _ _ _).eval env = .some d3 at h3 - obtain ⟨d4, h4⟩ := bd_elim h3 - -- h4 : (mloop').snd n .eval env = some d4. .snd = head (tail _). - change (Prog.elim _ _ _).eval env = .some d4 at h4 - obtain ⟨d5, h5⟩ := bd_elim h4 - -- h5 : (tail mloop') n .eval env = some d5. tail = elim _ empty (fun _ tl => tl). - change (Prog.elim _ _ _).eval env = .some d5 at h5 - obtain ⟨d6, h6⟩ := bd_elim h5 - -- h6 : mloop' n .eval env = some d6. Done. - exact ⟨d6, h6⟩ - -/-- Converse of `universal_tm_simulates` (loose form). If `universal_tm`, applied to -a correctly-encoded `((q₀, transitionTable), w)`, evaluates to `w'` under env `env`, -then there exists an iteration index `n` such that the TM is in a halt state and -the tape contents under the head (with blanks discarded) equal `w'`. -/ -theorem universal_tm_simulates_converse [Inhabited Symbol] [Fintype Symbol] - [DecidableEq Symbol] {tm : SingleTapeTM Symbol} - [DataEncode tm.State] [DecidableEq tm.State] - {env : List Data} {p_input : PB} {w w' : List Symbol} - (h_input : p_input.ComputesEnc env - ((tm.q₀, - (Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c'))))), - w)) - (h_out : (universal_tm p_input).ComputesEnc env w') : - ∃ n : ℕ, - let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) - cfg.state = none ∧ - (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' := by - set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep - by_cases h_halts : ∃ n, (step^[n] (tm.initCfg w)).state = none - · -- Halts: use forward direction to identify the output. - refine ⟨Nat.find h_halts, Nat.find_spec h_halts, ?_⟩ - have h_fwd := universal_tm_computes (tm := tm) h_input h_halts - -- Both `h_fwd` and `h_out` give an evaluation of `universal_tm p_input` at `env`; - -- since `Part.eval` is functional, the encoded values must agree, then apply - -- injectivity of `DataEncode.encode`. - have h1 := h_fwd [] - have h2 := h_out [] - simp only [List.length_nil, Nat.add_zero, List.append_nil] at h1 h2 - rw [h1] at h2 - have h_eq := Part.some_inj.mp (by exact_mod_cast h2) - exact DataEncode.h_inj h_eq - · -- Does not halt: derive a contradiction from `h_out` via `whileFrom_eval_some`. - exfalso - have h_eval := h_out [] - simp only [List.length_nil, Nat.add_zero, List.append_nil] at h_eval - obtain ⟨d, h_loop⟩ := universal_tm_eval_some_imp_loop_eval_some h_eval - -- Project `h_input` to get individual components. - have h_q₀ := PB.fst_computes_enc (PB.fst_computes_enc h_input) - have h_tr := PB.snd_computes_enc (PB.fst_computes_enc h_input) - have h_inp := PB.snd_computes_enc h_input - -- Initial config evaluates to `encode (tm.initCfg w)`. - have h_init_eval : (initial_config p_input.fst.fst p_input.snd env.length).eval env - = .some (DataEncode.encode (tm.initCfg w)) := by - have := (initial_config_computes h_q₀ h_inp) [] - simpa using this - -- Unfold tm_main_loop = PB.while_ init body. - set body_pb : PB → PB := - fun acc => PB.optionElim (singleTapeTM_step p_input.fst.snd acc) acc - (fun next => next) with body_pb_def - change (PB.while_ (initial_config p_input.fst.fst p_input.snd) body_pb env.length).eval env - = .some d at h_loop - set bd : Prog := body_pb (fun _ => .var env.length) (env.length + 1) with bd_def - change (Prog.while_ (initial_config p_input.fst.fst p_input.snd env.length) bd).eval env - = .some d at h_loop - rw [Prog.while_eval, h_init_eval, Part.bind_some] at h_loop - -- Extract the trajectory. - obtain ⟨m, traj, h_traj0, h_trajm, h_halt_at_m, h_steps⟩ := - Prog.whileFrom_eval_some h_loop - -- The body computes `step` at every config. - have h_body_eval : ∀ c : tm.Cfg, - bd.eval (env ++ [DataEncode.encode c]) = .some (DataEncode.encode (step c)) := by - intro c - have h := (tm_main_loop_body_computes h_tr c (ext := [])).here - simpa [bd_def, body_pb_def, PB.atSlot, hstep] using h - -- Induction: `traj k = encode (step^[k] (tm.initCfg w))` for `k ≤ m`. - have h_traj_eq : ∀ k, k ≤ m → traj k = DataEncode.encode (step^[k] (tm.initCfg w)) := by - intro k hk - induction k with - | zero => simpa using h_traj0 - | succ k ih => - have hkm : k < m := hk - have ih' := ih (Nat.le_of_lt hkm) - have h_step_k := (h_steps k hkm).2 - rw [ih', h_body_eval] at h_step_k - have h_eq : traj (k + 1) = DataEncode.encode (step (step^[k] (tm.initCfg w))) := - (Part.some_inj.mp h_step_k).symm - rw [h_eq, show step (step^[k] (tm.initCfg w)) = step^[k+1] (tm.initCfg w) from - (Function.iterate_succ_apply' step k _).symm] - -- Halt condition at `m` gives `state = none`. - have h_at_m : traj m = DataEncode.encode (step^[m] (tm.initCfg w)) := h_traj_eq m le_rfl - rw [← h_trajm, h_at_m] at h_halt_at_m - have headD_iff : ∀ c : tm.Cfg, - (DataEncode.encode c).asList.headD (Data.l []) = Data.l [] ↔ c.state = none := by - rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode, DataEncode_pair, Data.asList] - exact h_halts ⟨m, (headD_iff _).mp h_halt_at_m⟩ - -/-- Local alternative output predicate: `tm` (lifted to a total step function) reaches -a halted configuration whose tape content (head followed by the right stack, with -blanks discarded) equals `w'`. Used to phrase the combined `iff` characterization -of `universal_tm`. -/ -private def Outputs' {Symbol : Type} [Inhabited Symbol] [Fintype Symbol] - (tm : SingleTapeTM Symbol) (w w' : List Symbol) : Prop := - ∃ n : ℕ, - let cfg := (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) - cfg.state = none ∧ - (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption = w' - -private theorem universal_tm_simulates_iff [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] - {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] - {env : List Data} {p_input : PB} {w w' : List Symbol} - (h_input : p_input.ComputesEnc env - ((tm.q₀, - (Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c'))))), - w)) : - Outputs' tm w w' ↔ (universal_tm p_input).ComputesEnc env w' := by - set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hstep_def - have halt_fix : ∀ {c : tm.Cfg}, c.state = none → step c = c := by - rintro ⟨_, _⟩ rfl; rfl - have halt_fix_iter : ∀ (k : ℕ) {c : tm.Cfg}, c.state = none → step^[k] c = c := by - intro k _ hc - induction k with - | zero => rfl - | succ k ih => rw [Function.iterate_succ_apply', ih, halt_fix hc] - refine ⟨?_, ?_⟩ - · -- Forward: `Outputs' tm w w' → universal_tm computes w'`. - rintro ⟨n, h_halt_n, h_eq⟩ - have h_halts : ∃ k, (step^[k] (tm.initCfg w)).state = none := ⟨n, h_halt_n⟩ - have h := universal_tm_computes (tm := tm) h_input h_halts - -- Stationarity: any later iterate of a halted config equals it. - have h_le : Nat.find h_halts ≤ n := Nat.find_le h_halt_n - have h_iter := halt_fix_iter (n - Nat.find h_halts) (Nat.find_spec h_halts) - rw [← Function.iterate_add_apply, Nat.sub_add_cancel h_le] at h_iter - rw [show ((fun c => (tm.step c).getD c)^[Nat.find h_halts] (tm.initCfg w)) = - (fun c => (tm.step c).getD c)^[n] (tm.initCfg w) from h_iter.symm, h_eq] at h - exact h - · -- Converse: directly from `universal_tm_simulates_converse`. - intro h_out - exact universal_tm_simulates_converse h_input h_out - + rw [show step c = c from by simp only [step_def, hsc, Option.getD_none]] + exact PB.optionElim_computesEnc_none (hsc ▸ h_step) h_acc + | some next => + rw [show step c = next from by simp only [step_def, hsc, Option.getD_some]] + refine PB.optionElim_computesEnc_some (hsc ▸ h_step) ?_ + apply PB.computesFun₂_branch + intro ext2 + exact PB.var_computes_fresh ext2 [.data (Data.l [])] + -- Iterate the body from `c` to its halting configuration after `n` steps. + have loop : ∀ (n : ℕ) (c : tm.Cfg), (step^[n] c).state = none → + PB.WhileComputes env + (fun acc => PB.optionElim (singleTapeTMStep p_tr acc) acc (fun next => next)) + (DataEncode.encode c) (DataEncode.encode (step^[n] c)) := by + intro n + induction n with + | zero => exact fun c hc => PB.WhileComputes.halt ((headEmpty_iff c).mpr hc) + | succ n ih => + intro c hc + by_cases hstate : c.state = none + · rw [Function.iterate_fixed (halt_fix c hstate) (n + 1)] + exact PB.WhileComputes.halt ((headEmpty_iff c).mpr hstate) + · rw [Function.iterate_succ, Function.comp_apply] at hc ⊢ + exact PB.WhileComputes.step + (fun h => hstate ((headEmpty_iff c).mp h)) (body_computes c) (ih (step c) hc) + apply PB.while_computes h_cfg + exact loop (Nat.find h_halts) cfg (Nat.find_spec h_halts) end RoseTreeMachine From 825693b66300682a13c325a32232cf997fbc8ffa Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 11 Jun 2026 15:38:45 +0200 Subject: [PATCH 04/22] cleanup --- Cslib/Computability/Machines/RTM/Data.lean | 14 +++ .../Machines/RTM/DataEncode.lean | 10 +++ Cslib/Computability/Machines/RTM/PB.lean | 46 +++++++++- Cslib/Computability/Machines/RTM/Prog.lean | 44 ++++++--- .../Machines/RTM/TMSimulator.lean | 90 ++++++++----------- Cslib/Computability/Machines/RTM/Tools.lean | 21 ++++- 6 files changed, 155 insertions(+), 70 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Data.lean b/Cslib/Computability/Machines/RTM/Data.lean index 3f482b203..20a842b0e 100644 --- a/Cslib/Computability/Machines/RTM/Data.lean +++ b/Cslib/Computability/Machines/RTM/Data.lean @@ -9,6 +9,20 @@ module public import Cslib.Init public import Mathlib.Data.Part +/-! +# Main internal data type for the rose tree machine (RTM) + +This file contains the main internal data structure for the RTM, `Data`, a rose tree. + +## Main definitions and notations + +- `Data` - the main data structure +- `Data.size` - the size of a `Data` object when encoded using parentheses, complexity results + use this size as the main measure. +- `Data.recL` - the main recursion principle for `Data` +- `Data.inductionL` - the main induction principle for `Data` + +-/ @[expose] public section diff --git a/Cslib/Computability/Machines/RTM/DataEncode.lean b/Cslib/Computability/Machines/RTM/DataEncode.lean index ff809f4b4..84bebca95 100644 --- a/Cslib/Computability/Machines/RTM/DataEncode.lean +++ b/Cslib/Computability/Machines/RTM/DataEncode.lean @@ -10,6 +10,16 @@ public import Cslib.Computability.Machines.RTM.Data public import Mathlib.Data.Nat.Bits public import Mathlib.Data.List.Basic +/-! +# Encodings into `Data` + +This file defines the class that is used to encode arbitrary data structures into `Data`, +so that RTMs (rose tree machines) can operate on them. + +Instances are provided for convenience for `Data` itself, `Bool`, `List α`, `Option α`, `α × β`, +and `ℕ` (binary encoding via `List Bool`) + +-/ @[expose] public section diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index d2de83d0f..d145ecaf8 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -9,11 +9,49 @@ module public import Cslib.Computability.Machines.RTM.Prog public import Cslib.Computability.Machines.RTM.DataEncode -/-! # RoseTreeMachine — PB (program builder) +/-! # Program builder for rose tree machines + +This is a thin layer over the `Prog`s of rose tree machines, allowing to better +handle the absolute de-Bruijn levels of variables in `Prog`s. +It contains the main atoms and combinators for constructing rose tree machines. + +The main idea is that a `PB` (program builder) receives the current variable depth as an argument +and then returns a `Prog` that may refer to variables at that depth or below. + +Furthermore, this file contains routines to help reason about the semantics of constructed +programs both in terms of computations on `Data` but also in terms of computations on arbitrary +lean types that implement` DataEncode`. + + +## Main definitions and notations + +The atoms and combinators mirroring the constructors of `Prog`: +- `PB.var i` - read the `i`-th variable from the environment +- `PB.empty` - the empty list `[]` +- `PB.cons h t` - cons the head `h` and tail `t` into a list +- `PB.elim v em cs` - elimination of `v` into a nil branch `em` and a curried cons branch `cs` +- `PB.ifEq x y then_ else_` - if-then-else on the equality of `x` and `y` +- `PB.while_ init body` - a `while` loop with initializer `init` and body `body`, the body receives + a builder for the loop body, which is passed the fresh variable for the accumulator +- `PB.fn body` - a literal abstraction (a `let` binding), the body receives a builder for the + function body, which is passed the fresh variable for the parameter +- `PB.app f a` - application of `f` to `a` + +Semantics: + +- `PB.Computes` - resource-erased relational semantics for the program builder +- `PB.ComputesEnc` - variant of `PB.Computes` for `DataEncode`-able types. + +Resource consumption: + +- `PB.OutputsOSize` - the output size of the program is linear in the size of the input environment +- `PB.UsesOTime` - the time used by the program is linear in the size of the input environment +- `PB.UsesOSpace` - the space used by the program is linear in the size of the input environment +- `PB.UsesLinearTimeAndSpace` - the program uses linear time and space in the size of the input -A thin builder layer over the de-Bruijn-levelled `Prog`. -/ + @[expose] public section namespace Turing @@ -29,13 +67,13 @@ namespace PB def var (i : ℕ) : PB := fun _ => .var i def empty : PB := fun _ => .empty def cons (h t : PB) : PB := fun n => .cons (h n) (t n) -def fn (body : PB → PB) : PB := fun n => .fn (body (var n) (n + 1)) -def app (f a : PB) : PB := fun n => .app (f n) (a n) def elim (v em : PB) (cs : PB → PB → PB) : PB := fun n => .elim (v n) (em n) (.fn (.fn (cs (var n) (var (n + 1)) (n + 2)))) def ifEq (x y then_ else_ : PB) : PB := fun n => .ifEq (x n) (y n) (then_ n) (else_ n) def while_ (init : PB) (body : PB → PB) : PB := fun n => .while_ (init n) (.fn (body (var n) (n + 1))) +def fn (body : PB → PB) : PB := fun n => .fn (body (var n) (n + 1)) +def app (f a : PB) : PB := fun n => .app (f n) (a n) /-- Close a builder into a concrete `Prog`. -/ def build (p : PB) : Prog := p 0 diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index 6132cfd15..4c3fb13e6 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -9,6 +9,27 @@ module public import Cslib.Computability.Machines.RTM.Data public import Cslib.Computability.Machines.RTM.DataEncode + +/-! +# Programs in a rose tree machine (RTM) + +This file contains the main definition of the rose tree machine, its programs including +semantics and time and space resource consumption. + +## Main definitions and notations + +- `Prog` - the program +- `ProgSem` - semantics and resource consumption +- `InPlace` - a fragment of the language that can be easily simulated using multi-tape Turing + machines. +- `Prog.ComputesInTimeAndSpace` - this defines the complexity notion for the RTM computation model, + based on `Data` values. +- `Prog.ComputesBoolFunInTimeAndSpace` - the complexity notion transferred to functions on binary + strings, this making it compatible to all other computation models. +- `ComputableInOTime` - generic time-complexity in the RTM model +- `ComputableInOSpace` - generic space-complexity in the RTM model +-/ + @[expose] public section namespace Turing @@ -55,15 +76,11 @@ def Value.size : Value → ℕ | .data d => d.size | .closure _ env => 2 + (env.map Value.size).sum -/-- The empty first-order value. -/ abbrev Value.empty : Value := .data (Data.l []) @[simp] lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size] -@[simp] -lemma Value.size_empty : Value.empty.size = 2 := by simp - mutual /-- Semantics of `Prog` including time and space resource bounds. `ProgSem σ p x t s` means that on environment `σ`, the program `p` evaluates to the value @@ -83,7 +100,7 @@ inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop /-- `elim`, cons branch: `v` destructures to `hd :: tl`; evaluate the function `cs` to a closure and apply it first to `hd` and then to `tl` (so `cs` is a curried two-argument function). - TODO: We could syntactically require that hte `cs` argument always has the form + TODO: We could syntactically require that the `cs` argument always has the form `.fn .fn ...`, then we could change the cost function so that we do not need to charge for creating the closure (and the same for all similar constructs). -/ @@ -121,10 +138,7 @@ inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop size of the resulting closure (mirroring `var`, which charges the size of the value it produces). TODO: We could charge only the size of the referenced variables, which would make it - more or less free to create a non-capturing closure. - TODO: An earlier version did not charge for the environment in case an abstraction is directly - applied (more specifically, it did not even have abstractions or closures), - which makes it easier to simulate on a Turing machine. -/ + more or less free to create a non-capturing closure. -/ | fn : ProgSem σ (.fn body) (.closure body σ) (Value.closure body σ).size (Value.closure body σ).size @@ -141,8 +155,8 @@ inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop closure `f` to the argument `v` yields `r` using `t` time and `s` space. Only closures can be applied; applying a first-order value has no derivation (the program is stuck). -/ inductive AppSem : Value → Value → Value → ℕ → ℕ → Prop - | mk (h_body : ProgSem (σ' ++ [v]) body r t s) : - AppSem (.closure body σ') v r t s + | mk (h_body : ProgSem (σ ++ [v]) body r t s) : + AppSem (.closure body σ) v r t s /-- Iterates the closure `bodyVal` of a `while_` loop, threading the accumulator. `WhileSem bodyVal acc r t s` means that, starting from accumulator `acc`, repeatedly applying @@ -173,6 +187,14 @@ def Prog.ComputesBoolFunInTimeAndSpace ∀ x, ∃ t' ≤ t x.length, ∃ s' ≤ s x.length, Prog.ComputesInTimeAndSpace p (DataEncode.encode x) (DataEncode.encode (f x)) t' s' +/-- The function `f` is computable in time `t` in the RTM model, up to constant factors -/ +def ComputableInOTime (f : List Bool → List Bool) (t : ℕ → ℕ) : Prop := + ∃ p a s, Prog.ComputesBoolFunInTimeAndSpace p f (fun n => a * (t n) + a) s + +/-- The function `f` is computable in space `s` in the RTM model, up to constant factors -/ +def ComputableInOSpace (f : List Bool → List Bool) (s : ℕ → ℕ) : Prop := + ∃ p a t, Prog.ComputesBoolFunInTimeAndSpace p f t (fun n => a * (s n) + a) + /-- The *in-place* (first-order) fragment of the functional language. `InPlace p` holds when every `fn` in `p` occurs in an immediately-consumed position — as the diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 6932f04ea..dbcc880bf 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -10,6 +10,27 @@ public import Cslib.Computability.Machines.RTM.Tools public import Cslib.Computability.Machines.SingleTapeTuring.Basic public import Mathlib.Data.List.ReduceOption +/-! # Universal Turing-machine simulator as a rose tree machine + +This file defines a rose tree machine that universally simulates all one-tape Turing machines +(for a fixed alphabet). + +This means it constructs a `Prog` `p` such that for any Turing machine `tm`, and any input string +`input` when `p` is run on `DataEncode.encode (tm, input)`, in outputs the result of the execution +of the `tm` (if it halts), and does that with a linear overhead in space and a quadratic overhead +in time (conjectured). + +TODO: + +Extend this such that `p` receives a time bound `t` and then simulates the Turing machine +for exactly `t` steps, and also counts (and returns) the space usae of the Turing machine. +This should allow us to prove most of the diagonalization results. + +Note that the proofs of semantic for loop-free programs directly model the computation. we should +write a tactic to automate this. + +-/ + @[expose] public section namespace Turing @@ -53,14 +74,7 @@ lemma bitape_write_computes (bitapeWrite p_tape p_sym).ComputesEnc env (tape.write sym) := by apply PB.cons_computes h_sym (PB.tail_computes h_tape) --- /-- Prepend an `Option` to the `StackTape` -/ --- @[scoped grind] --- def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol := --- match x, xs with --- | none, ⟨[], _⟩ => ⟨[], by grind⟩ --- | none, ⟨hd :: tl, hl⟩ => ⟨none :: hd :: tl, by grind⟩ --- | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩ - +/-- Models `StackTape.cons` -/ def stackTapeCons (x st : PB) : PB := PB.optionElim x (PB.elim st @@ -129,9 +143,7 @@ lemma stackTapeTail_computes {p_st : PB} {st : StackTape Symbol} unfold PB.ComputesEnc simpa [← encode_stackTape_tail] using PB.tail_computes h_st --- def move_left (t : BiTape Symbol) : BiTape Symbol := --- ⟨t.left.head, t.left.tail, StackTape.cons t.head t.right⟩ - +/-- Models `BiTape.moveLeft` -/ def bitapeMoveLeft (t : PB) : PB := PB.toPair (bitapeLeft t).head (PB.toPair @@ -146,9 +158,7 @@ lemma bitapeMoveLeft_computes {p_t : PB} {t : BiTape Symbol} (h_t : p_t.Computes (stackTapeTail_computes (bitapeLeft_computes h_t)) (stackTapeCons_computes (bitapeHead_computes h_t) (bitapeRight_computes h_t))) --- def move_right (t : BiTape Symbol) : BiTape Symbol := --- ⟨t.right.head, StackTape.cons t.head t.left, t.right.tail⟩ - +/-- Models `BiTape.moveRight` -/ def bitapeMoveRight (t : PB) : PB := PB.toPair (bitapeRight t).head (PB.toPair @@ -169,13 +179,7 @@ instance : DataEncode Dir where | Dir.right => DataEncode.encode false h_inj := by intro a b h; cases a <;> cases b <;> simp_all [DataEncode.encode] --- /-- --- Move the head to the left or right, shifting the tape underneath it. --- -/ --- def move (t : BiTape Symbol) : Dir → BiTape Symbol --- | .left => t.move_left --- | .right => t.move_right - +/-- Models `BiTape.move` -/ def bitapeMove (tape dir : PB) : PB := PB.ifEq dir (PB.constantEnc Dir.left) (bitapeMoveLeft tape) @@ -191,13 +195,7 @@ lemma bitapeMove_computes {p_t p_dir : PB} {t : BiTape Symbol} {d : Dir} | .right => PB.ifeq_ne_computes h_dir PB.constantEnc_computesEnc (by decide) (bitapeMoveRight_computes h_t) --- /-- --- Optionally perform a `move`, or do nothing if `none`. --- -/ --- def optionMove : BiTape Symbol → Option Dir → BiTape Symbol --- | t, none => t --- | t, some d => t.move d - +/-- Models `BiTape.optionMove` -/ def bitapeOptionMove (t dir : PB) : PB := PB.optionElim dir t @@ -214,6 +212,7 @@ lemma bitapeOptionMove_computes {p_t p_dir : PB} PB.optionElim_computesEnc_some h_dir (PB.computesFun₂_branch (fun ext => bitapeMove_computes (h_t.extend ext |>.extend _) (PB.var_computes_fresh ext _))) +/-- Encoding of a `SingleTapeTM`, assuming the state set and alphabet are encodable. -/ instance [Inhabited Symbol] [Fintype Symbol] (tm : SingleTapeTM Symbol) [DataEncode tm.State] : DataEncode (Turing.SingleTapeTM.Cfg tm) where encode cfg := DataEncode.encode (cfg.state, cfg.BiTape) @@ -270,19 +269,8 @@ lemma evalTr_computes {State : Type} [Fintype State] [DataEncode State] (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c'))) h_tr h_q) h_c --- /-- The step function corresponding to a `SingleTapeTM`. -/ --- @[simp] --- def step : tm.Cfg → Option tm.Cfg --- | ⟨none, _⟩ => --- -- If in the halting state, there is no next configuration --- none --- | ⟨some q', t⟩ => --- -- If in state q', perform look up in the transition function --- match tm.tr q' t.head with --- -- and enter a new configuration with state q'' (or none for halting) --- -- and tape updated according to the Stmt --- | ⟨⟨wr, dir⟩, q''⟩ => some ⟨q'', (t.write wr).optionMove dir⟩ - +/-- The part of `SingleTapeTM.step` that applies the output of the transition function to the +configuration. -/ def applyTrVal (trVal cfg : PB) : PB := .some (PB.toPair trVal.snd @@ -305,8 +293,8 @@ lemma applyTrVal_computes · exact PB.fst_ComputesEnc (a := (trVal.fst.1, trVal.fst.2)) (PB.fst_ComputesEnc h_tr) · exact PB.snd_ComputesEnc (a := (trVal.fst.1, trVal.fst.2)) (PB.fst_ComputesEnc h_tr) --- Compute the step function given a transition function (as its graph) and a configuration. --- Returns `Option Cfg` +/-- Models `SingleTapeTM.step`: Compute the step function given a transition function +(as its graph, a list of input-output pairs) and a configuration. Returns `Option Cfg`. -/ def singleTapeTMStep (tr : PB) (cfg : PB) : PB := PB.optionElim (cfgState cfg) PB.empty @@ -338,6 +326,8 @@ lemma singleTapeTMStep_computes refine evalTr_computes (h_tr.extend ext |>.extend _) (PB.var_computes_fresh ext _) ?_ exact PB.head_computes (cfg_bitape_computes (h_cfg.extend ext |>.extend _)) +/-- The main loop of the Turing machine simulation: Execute a step until we reach a halting +configuration, then return it. -/ def tmMainLoop (tr : PB) (cfg : PB) : PB := -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step` -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep @@ -345,14 +335,6 @@ def tmMainLoop (tr : PB) (cfg : PB) : PB := PB.while_ cfg (fun acc => PB.optionElim (singleTapeTMStep tr acc) acc (fun next => next)) -partial def simulateTM - [Inhabited Symbol] [Fintype Symbol] - {tm : SingleTapeTM Symbol} - (cfg : tm.Cfg) := - match tm.step cfg with - | none => cfg - | some cfg' => simulateTM cfg' - lemma tmMainLoop_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} @@ -418,6 +400,12 @@ lemma tmMainLoop_computes apply PB.while_computes h_cfg exact loop (Nat.find h_halts) cfg (Nat.find_spec h_halts) + +/- TODO: What is left to do here is + - construct the initial configuration from the input string + - extract the output string from the final configuration. + - and of course prove the resource bounds +-/ end RoseTreeMachine end Turing diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index fa9860cfd..4532d2ebe 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -12,11 +12,24 @@ public import Mathlib.Data.List.ReduceOption public import Cslib.Computability.Machines.RTM.PB public import Cslib.Computability.Machines.RTM.DataEncode -/-! # RoseTreeMachine V4 — Tools +/-! # Tools for rose tree machines + +Derived program-builder combinators and their semantics for working with basic data types like +pairs, `Option`, etc. plus a set of lemmas to help reasoning about the semantics of while loops. + +## Main definitions and notations + +- `PB.head`, `PB.tail` - get the head and tail of a list-valued builder +- `PB.fst`, `PB.snd` - get the first and second component of a pair (encoded as a two-element list) +- `PB.some` - encode an `Option.some` as a singleton list +- `PB.optionElim` - eliminate an `Option` by branching on whether a builder is empty or not +- `PB.toPair` - encode a pair as a two-element list +- `PB.constant` - build a builder that evaluates to a constant `Data` value + +- `PB.fold` - left fold of a body over a list, implemented with `while_` +- `PB.evalFunGraph` - evaluate a function given as a graph (list of input-output pairs) at an + argument, implemented with `while_` -Derived program-builder combinators. Because the V4 builder keeps the same HOAS `elim` -signature as the first-order development, these definitions are identical to their -counterparts there; only the underlying semantics (functional `elim`/`while_`) differs. -/ @[expose] public section From de4941e363de0979f25dd594529027a7908ac4be Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 11 Jun 2026 18:11:40 +0200 Subject: [PATCH 05/22] more tools. --- Cslib/Computability/Machines/RTM/PB.lean | 13 ++ .../Machines/RTM/TMSimulator.lean | 1 + Cslib/Computability/Machines/RTM/Tools.lean | 118 +++++++++++++++--- 3 files changed, 118 insertions(+), 14 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index d145ecaf8..37e3f12fa 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -156,6 +156,11 @@ lemma empty_computes : Computes env empty (.data (.l [])) := by intro ext exact ⟨2, 2, ProgSem.empty⟩ +@[simp] +lemma empty_computesEnc (α : Type) [DataEncode α] : empty.ComputesEnc env ([] : List α) := by + intro ext + exact ⟨2, 2, ProgSem.empty⟩ + @[simp] lemma cons_computes {h t : PB} {dh dt : Data} (hh : Computes env h (.data dh)) (ht : Computes env t (.data dt)) : @@ -165,6 +170,14 @@ lemma cons_computes {h t : PB} {dh dt : Data} obtain ⟨tt, st, ht'⟩ := ht ext exact ⟨_, _, ProgSem.cons hh' ht'⟩ +lemma cons_computesEnc {α : Type} [DataEncode α] {p_hd p_tl : PB} {hd : α} {tl : List α} + (h_hd : p_hd.ComputesEnc env hd) (h_tl : p_tl.ComputesEnc env tl) : + (PB.cons p_hd p_tl).ComputesEnc env (hd :: tl) := by + intro ext + obtain ⟨th, sh, hh'⟩ := h_hd ext + obtain ⟨tt, st, ht'⟩ := h_tl ext + exact ⟨_, _, ProgSem.cons hh' ht'⟩ + /-- A `PB.var` at the absolute level of the `j`-th freshly-bound variable reads `binds[j]`. -/ @[simp] lemma var_computesFun {binds : List Value} {j : ℕ} (ext : List Value) : diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index dbcc880bf..d0dd22839 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -401,6 +401,7 @@ lemma tmMainLoop_computes exact loop (Nat.find h_halts) cfg (Nat.find_spec h_halts) + /- TODO: What is left to do here is - construct the initial configuration from the input string - extract the output string from the final configuration. diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index 4532d2ebe..29215da54 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -26,7 +26,7 @@ pairs, `Option`, etc. plus a set of lemmas to help reasoning about the semantics - `PB.toPair` - encode a pair as a two-element list - `PB.constant` - build a builder that evaluates to a constant `Data` value -- `PB.fold` - left fold of a body over a list, implemented with `while_` +- `PB.foldl` - left fold of a body over a list, implemented with `while_` - `PB.evalFunGraph` - evaluate a function given as a graph (list of input-output pairs) at an argument, implemented with `while_` @@ -149,19 +149,109 @@ lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : simp [ComputesEnc, constantEnc] -------------- while semantics ------------------------ - - -/-- `fold body init list`: left fold of `body` (taking `acc` then `el`) over `list`. - -Implemented with `while_` over a `[remaining, acc]` pair: the loop halts once `remaining` -(the *head* of the accumulator, which is what `while_` inspects) becomes empty; otherwise it -splits off the first element `el`, updates the accumulator to `[rest, body acc el]`, and -continues. The fold's result is the final `acc` (the second component). -/ -def fold (body : PB → PB → PB) (init list : PB) : PB := - snd (PB.while_ (PB.toPair list init) - (fun st => elim (PB.fst st) empty - (fun el rest => toPair rest (body (PB.snd st) el)))) +/-- `foldl f init list`: left fold of `f` (taking `acc` then `el`) over `list`. -/ +def foldl (f : PB → PB → PB) (init list : PB) : PB := + snd (PB.while_ (toPair list init) + (fun st => elim st.fst empty + (fun el rest => toPair rest (f st.snd el)))) + +lemma foldl_computes + {p_f : PB → PB → PB} {p_init p_list : PB} + {init : α} {list : List β} {f : α → β → α} + (h_init : p_init.ComputesEnc env init) + (h_list : p_list.ComputesEnc env list) + (h_f : ∀ {e : List Value} {pa pb : PB} {a : α} {b : β}, + pa.ComputesEnc e a → pb.ComputesEnc e b → (p_f pa pb).ComputesEnc e (f a b)) : + (foldl p_f p_init p_list).ComputesEnc env (list.foldl f init) := by + -- One iteration of the loop body: from `(hd :: tl, acc)` to `(tl, f acc hd)`. + have foldl_step : ∀ (acc : α) (hd : β) (tl : List β), + computesFun₁ env (.data (DataEncode.encode (hd :: tl, acc))) + (fun st => elim st.fst empty (fun el rest => toPair rest (p_f st.snd el))) + (.data (DataEncode.encode (tl, f acc hd))) := by + intro acc hd tl + apply computesFun₁_branch + intro ext + refine elim_cons_computes + (fst_ComputesEnc (var_computes_fresh ext [])) (computesFun₂_branch2 ?_) + intro ext2 + refine toPair_computesEnc (var_computes_fresh2 ext2 []) (h_f ?_ (var_computes_fresh ext2 _)) + exact snd_ComputesEnc + (((var_computes_fresh ext []).extend ext2).extend [_, _]) + -- Iterate the body from `(li, acc)` to its final folded accumulator `([], li.foldl f acc)`. + have h_loop : ∀ (li : List β) (acc : α), + WhileComputes env + (fun st => elim st.fst empty + (fun el rest => toPair rest (p_f st.snd el))) + (DataEncode.encode (li, acc)) + (DataEncode.encode (([] : List β), li.foldl f acc)) := by + intro li + induction li with + | nil => + intro acc + apply WhileComputes.halt + simp [DataEncode.encode] + | cons hd tl ih => + intro acc + simp only [List.foldl_cons] + exact WhileComputes.step (by simp [DataEncode.encode]) (foldl_step acc hd tl) (ih (f acc hd)) + exact snd_ComputesEnc (while_computes + (toPair_computesEnc h_list h_init) (h_loop list init)) + +/-- Models `List.reverse`. -/ +def reverse (x : PB) : PB := + foldl (fun acc el => cons el acc) empty x + +lemma reverse_computes {p : PB} {l : List α} (h : p.ComputesEnc env l) : + (reverse p).ComputesEnc env l.reverse := by + have h_fold : l.reverse = l.foldl (fun acc el => el :: acc) [] := by simp + rw [h_fold] + apply foldl_computes (by simp) h + intro env p_tl p_hd tl hd h_tl h_hd + exact cons_computesEnc h_hd h_tl + +/-- Models `List.map`. -/ +def listMap (x : PB) (f : PB → PB) : PB := + reverse (foldl (fun acc el => cons (f el) acc) empty x) + +lemma listMap_computes + {p_l : PB} {p_f : PB → PB} + {l : List α} + {f : α → β} + (h_l : p_l.ComputesEnc env l) + (h_f : ∀ {e : List Value} {px : PB} {x : α}, + px.ComputesEnc e x → (p_f px).ComputesEnc e (f x)) : + (listMap p_l p_f).ComputesEnc env (l.map f) := by + have : l.map f = (l.foldl (fun acc el => f el :: acc) []).reverse := by simp + rw [this] + apply reverse_computes (foldl_computes (empty_computesEnc β) h_l ?_) + intro e p_acc p_el acc el h_acc h_el + exact cons_computesEnc (h_f h_el) h_acc + + +/-- Models `List.reduceOption`, i.e. discards `none` elements, keeping the `some` payloads. -/ +def listReduceOption (x : PB) : PB := + reverse (foldl + (fun acc el => optionElim el acc (fun y => PB.cons y acc)) + empty x) + +lemma listReduceOption_computes {p : PB} {l : List (Option α)} (h : p.ComputesEnc env l) : + (listReduceOption p).ComputesEnc env l.reduceOption := by + have h_reduceOption_via_fold (m : List (Option α)) : ∀ (a : List α), + (m.foldl (fun acc el => match el with | .none => acc | .some y => y :: acc) a).reverse + = a.reverse ++ m.reduceOption := by + induction m with + | nil => simp + | cons hd tl ih => + cases hd with | none | some _ => simp [ih] + rw [show l.reduceOption = (l.foldl _ []).reverse + from by simpa using (h_reduceOption_via_fold l []).symm] + apply reverse_computes ((foldl_computes (empty_computesEnc α) h) ?_) + intro e p_acc p_el acc el h_acc h_el + cases el with + | none => exact optionElim_computesEnc_none h_el h_acc + | some y => + apply optionElim_computesEnc_some h_el (computesFun₂_branch (fun ext => ?_)) + exact cons_computesEnc (var_computes_fresh ext _) ((h_acc.extend ext).extend _) -- Evaluate a function `f` at `arg` where the function is given as a graph (list of pairs). From a883bd9837549dea9c6e52efa8108735724798d5 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 11 Jun 2026 19:23:45 +0200 Subject: [PATCH 06/22] state thoerems for simulator. --- .../Machines/RTM/TMSimulator.lean | 56 +++++++++++++++++++ Cslib/Computability/Machines/RTM/Tools.lean | 12 ++++ 2 files changed, 68 insertions(+) diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index d0dd22839..0a1a6e5e3 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -400,6 +400,62 @@ lemma tmMainLoop_computes apply PB.while_computes h_cfg exact loop (Nat.find h_halts) cfg (Nat.find_spec h_halts) +def stringToTape (input : PB) : PB := + PB.toPair input.listHeadOption (PB.toPair .empty (input.tail.listMap .some)) + +def stringToTape_computes + {p_input : PB} + {input : List Symbol} + (h_input : p_input.ComputesEnc env input) : + (stringToTape p_input).ComputesEnc env (BiTape.mk₁ input) := by + sorry + +def initialConfig (q₀ : PB) (input : PB) : PB := + PB.toPair (.some q₀) (stringToTape input) + +lemma initialConfig_computes [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {p_q₀ p_input : PB} {input : List Symbol} + (h_q₀ : p_q₀.ComputesEnc env tm.q₀) + (h_input : p_input.ComputesEnc env input) : + (initialConfig p_q₀ p_input).ComputesEnc env (tm.initCfg input) := by + sorry + +def diverge : PB := .while_ (.toPair .empty .empty) fun acc => acc + +lemma diverge_computes {out : Value} : ¬ diverge.Computes env out := by + sorry + +def finalConfigToOutput (cfg : PB) : PB := + PB.ifEq (bitapeLeft (cfgBitape cfg)) PB.empty + (PB.cons (bitapeHead (cfgBitape cfg)) (bitapeRight (cfgBitape cfg))).listReduceOption + diverge + +lemma finalConfigToOutput_computes [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {p_cfg : PB} {cfg : tm.Cfg} + (h_cfg : p_cfg.ComputesEnc env cfg) : + (finalConfigToOutput p_cfg).ComputesEnc env + (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption ↔ + cfg.BiTape.left.toList = [] := by + sorry + +def tmSimulator (input : PB) := + finalConfigToOutput (tmMainLoop input.fst.snd (initialConfig input.fst.fst input.snd)) + +lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] + {p_input : PB} + {input output : List Symbol} + (h_input : p_input.ComputesEnc env + ((tm.q₀, + (Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c'))))), + input)) : + tm.Outputs input output ↔ (tmSimulator p_input).ComputesEnc env output := by + sorry + /- TODO: What is left to do here is diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index 29215da54..0e649eaa0 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -253,6 +253,18 @@ lemma listReduceOption_computes {p : PB} {l : List (Option α)} (h : p.ComputesE apply optionElim_computesEnc_some h_el (computesFun₂_branch (fun ext => ?_)) exact cons_computesEnc (var_computes_fresh ext _) ((h_acc.extend ext).extend _) +/-- Models `List.head?` -/ +def listHeadOption (input : PB) : PB := + PB.elim input empty (fun hd _tl => some hd) + +lemma listHeadOption_computes {p : PB} {l : List α} (h : p.ComputesEnc env l) : + (listHeadOption p).ComputesEnc env l.head? := by + cases l with + | nil => + apply PB.elim_nil_computes h (empty_computes) + | cons hd tl => + apply PB.elim_cons_computes h (PB.computesFun₂_branch2 (fun ext => ?_)) + refine PB.cons_computes (var_computes_fresh ext _) empty_computes -- Evaluate a function `f` at `arg` where the function is given as a graph (list of pairs). -- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise. From ecc3d9e0cdfacd5bf62eefd12202228f43a115ae Mon Sep 17 00:00:00 2001 From: crei Date: Fri, 12 Jun 2026 12:47:58 +0200 Subject: [PATCH 07/22] simulation in one direction. --- Cslib/Computability/Machines/RTM/Data.lean | 5 + Cslib/Computability/Machines/RTM/Prog.lean | 37 ++++ .../Machines/RTM/TMSimulator.lean | 180 +++++++++++++++--- Cslib/Computability/Machines/RTM/Tools.lean | 48 +++++ 4 files changed, 246 insertions(+), 24 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Data.lean b/Cslib/Computability/Machines/RTM/Data.lean index 20a842b0e..4b50a9d33 100644 --- a/Cslib/Computability/Machines/RTM/Data.lean +++ b/Cslib/Computability/Machines/RTM/Data.lean @@ -78,6 +78,11 @@ This is the encoded size assuming an encoding into parenthesized expressions. -/ def Data.size : Data → ℕ | Data.l xs => 2 + (xs.map Data.size |>.sum) +@[simp] +lemma Data.size_le {d : Data} : 0 < d.size := by + obtain ⟨xs⟩ := d + grind [Data.size] + @[simp, scoped grind =] lemma Data.size_empty : Data.empty.size = 2 := by simp [Data.empty, Data.size] diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index 4c3fb13e6..f4bed5423 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -81,6 +81,11 @@ abbrev Value.empty : Value := .data (Data.l []) @[simp] lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size] +lemma Value.size_pos {v : Value} : 0 < v.size := by + cases v with + | data d => simp only [Value.size]; exact Data.size_le + | closure _ env => simp only [Value.size]; omega + mutual /-- Semantics of `Prog` including time and space resource bounds. `ProgSem σ p x t s` means that on environment `σ`, the program `p` evaluates to the value @@ -176,6 +181,38 @@ inductive WhileSem : Value → Data → Data → ℕ → ℕ → Prop WhileSem bodyVal acc r (t_b + t_r) (max s_b s_r) end +/-- Every `ProgSem` derivation uses strictly positive time. -/ +theorem ProgSem.time_pos {σ : List Value} {p : Prog} {v : Value} {t s : ℕ} + (h : ProgSem σ p v t s) : 0 < t := by + induction p generalizing σ v t s <;> cases h <;> grind [Value.size_pos] + +/-- Every `AppSem` derivation uses strictly positive time. -/ +theorem AppSem.time_pos {f a v : Value} {t s : ℕ} (h : AppSem f a v t s) : 0 < t := by + cases h with + | mk hb => exact ProgSem.time_pos hb + +/-- Every `WhileSem` derivation uses strictly positive time. -/ +theorem WhileSem.time_pos {b : Value} {acc r : Data} {t s : ℕ} (h : WhileSem b acc r t s) : + 0 < t := by + cases h with + | halt => exact Data.size_le + | step hc hap hr => have := AppSem.time_pos hap; omega + +/-- The value produced by `ProgSem` is uniquely determined by the program and environment: +evaluation is deterministic (the time and space may in principle differ, but the result +cannot). + +TODO -/ +theorem ProgSem.det {σ : List Value} {p : Prog} {v₁ v₂ : Value} {t₁ s₁ t₂ s₂ : ℕ} + (h₁ : ProgSem σ p v₁ t₁ s₁) (h₂ : ProgSem σ p v₂ t₂ s₂) : v₁ = v₂ := by + induction t₁ using Nat.strong_induction_on generalizing σ p v₁ v₂ s₁ t₂ s₂ + rename_i t ih + cases p with + | var i => + have : v₂ = (σ[i]?.getD Value.empty) := by sorry --simp_all [h₂] + sorry + | _ => sorry + /-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/ def Prog.ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop := ProgSem [.data x] p (.data y) t s diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 0a1a6e5e3..973a3566b 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -231,7 +231,7 @@ lemma cfgState_computes [Inhabited Symbol] [Fintype Symbol] (cfgState p).ComputesEnc env cfg.state := PB.fst_ComputesEnc (a := (cfg.state, cfg.BiTape)) h -lemma cfg_bitape_computes [Inhabited Symbol] [Fintype Symbol] +lemma cfgBitape_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} (h : p.ComputesEnc env cfg) : @@ -289,7 +289,7 @@ lemma applyTrVal_computes (Option.some (⟨trVal.snd, (cfg.BiTape.write trVal.fst.1).optionMove trVal.fst.2⟩ : tm.Cfg)) := by refine PB.some_ComputesEnc (PB.toPair_computesEnc (PB.snd_ComputesEnc h_tr) ?_) - refine bitapeOptionMove_computes (bitape_write_computes (cfg_bitape_computes h_cfg) ?_) ?_ + refine bitapeOptionMove_computes (bitape_write_computes (cfgBitape_computes h_cfg) ?_) ?_ · exact PB.fst_ComputesEnc (a := (trVal.fst.1, trVal.fst.2)) (PB.fst_ComputesEnc h_tr) · exact PB.snd_ComputesEnc (a := (trVal.fst.1, trVal.fst.2)) (PB.fst_ComputesEnc h_tr) @@ -324,7 +324,7 @@ lemma singleTapeTMStep_computes intro ext refine applyTrVal_computes ?_ (h_cfg.extend ext |>.extend _) refine evalTr_computes (h_tr.extend ext |>.extend _) (PB.var_computes_fresh ext _) ?_ - exact PB.head_computes (cfg_bitape_computes (h_cfg.extend ext |>.extend _)) + exact PB.head_computes (cfgBitape_computes (h_cfg.extend ext |>.extend _)) /-- The main loop of the Turing machine simulation: Execute a step until we reach a halting configuration, then return it. -/ @@ -377,10 +377,8 @@ lemma tmMainLoop_computes exact PB.optionElim_computesEnc_none (hsc ▸ h_step) h_acc | some next => rw [show step c = next from by simp only [step_def, hsc, Option.getD_some]] - refine PB.optionElim_computesEnc_some (hsc ▸ h_step) ?_ - apply PB.computesFun₂_branch - intro ext2 - exact PB.var_computes_fresh ext2 [.data (Data.l [])] + refine PB.optionElim_computesEnc_some (hsc ▸ h_step) + (PB.computesFun₂_branch (fun ext2 => PB.var_computes_fresh ext2 _)) -- Iterate the body from `c` to its halting configuration after `n` steps. have loop : ∀ (n : ℕ) (c : tm.Cfg), (step^[n] c).state = none → PB.WhileComputes env @@ -397,18 +395,27 @@ lemma tmMainLoop_computes · rw [Function.iterate_succ, Function.comp_apply] at hc ⊢ exact PB.WhileComputes.step (fun h => hstate ((headEmpty_iff c).mp h)) (body_computes c) (ih (step c) hc) - apply PB.while_computes h_cfg - exact loop (Nat.find h_halts) cfg (Nat.find_spec h_halts) + exact PB.while_computes h_cfg (loop (Nat.find h_halts) cfg (Nat.find_spec h_halts)) def stringToTape (input : PB) : PB := PB.toPair input.listHeadOption (PB.toPair .empty (input.tail.listMap .some)) -def stringToTape_computes +lemma stringToTape_computes {p_input : PB} {input : List Symbol} (h_input : p_input.ComputesEnc env input) : (stringToTape p_input).ComputesEnc env (BiTape.mk₁ input) := by - sorry + cases input with + | nil => + refine PB.toPair_computesEnc (PB.listHeadOption_computes h_input) + (PB.toPair_computesEnc PB.empty_computes ?_) + exact PB.listMap_computes (l := []) + (PB.tail_computes h_input) (fun {e} px x hpx => PB.some_ComputesEnc hpx) + | cons hd tl => + refine PB.toPair_computesEnc (PB.listHeadOption_computes h_input) + (PB.toPair_computesEnc PB.empty_computes ?_) + exact PB.listMap_computes + (PB.tail_computes h_input) (fun {e} px x hpx => PB.some_ComputesEnc hpx) def initialConfig (q₀ : PB) (input : PB) : PB := PB.toPair (.some q₀) (stringToTape input) @@ -418,18 +425,18 @@ lemma initialConfig_computes [Inhabited Symbol] [Fintype Symbol] {p_q₀ p_input : PB} {input : List Symbol} (h_q₀ : p_q₀.ComputesEnc env tm.q₀) (h_input : p_input.ComputesEnc env input) : - (initialConfig p_q₀ p_input).ComputesEnc env (tm.initCfg input) := by - sorry - -def diverge : PB := .while_ (.toPair .empty .empty) fun acc => acc - -lemma diverge_computes {out : Value} : ¬ diverge.Computes env out := by - sorry - + (initialConfig p_q₀ p_input).ComputesEnc env (tm.initCfg input) := + PB.toPair_computesEnc (PB.some_ComputesEnc h_q₀) (stringToTape_computes h_input) + +/-- Compute the final output from the tape contents. +Note that since the single tape Turing machine requires the "left" part of the tape to be empty, +we need to produce "no output" if the left part of the tape is non-empty. The only way +for us to achieve that is to go into an infinite loop. This makes the semantics theorems a bit +more awkward. -/ def finalConfigToOutput (cfg : PB) : PB := PB.ifEq (bitapeLeft (cfgBitape cfg)) PB.empty (PB.cons (bitapeHead (cfgBitape cfg)) (bitapeRight (cfgBitape cfg))).listReduceOption - diverge + PB.diverge lemma finalConfigToOutput_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] @@ -438,13 +445,115 @@ lemma finalConfigToOutput_computes [Inhabited Symbol] [Fintype Symbol] (finalConfigToOutput p_cfg).ComputesEnc env (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption ↔ cfg.BiTape.left.toList = [] := by - sorry + constructor + · intro h_comp + by_contra h_left + obtain ⟨t, s, hps⟩ := h_comp [] + simp only [List.append_nil, List.length_nil, Nat.add_zero, + finalConfigToOutput, PB.ifEq, PB.empty] at hps + cases hps with + | ifEq_then h_x h_y h_then => + cases h_y + obtain ⟨tbl, sbl, hbl⟩ := (bitapeLeft_computes (cfgBitape_computes h_cfg)) [] + simp only [List.append_nil, List.length_nil, Nat.add_zero] at hbl + injection (ProgSem.det h_x hbl) with e1 + apply h_left + exact (DataEncode_list_eq_nil_iff_nil _).mp (e1.symm) + | ifEq_else h_x h_y hne h_else => exact PB.diverge_not_progSem h_else + · intro h_left + have h_bitape_left : cfg.BiTape.left = StackTape.nil := + DataEncode.h_inj (by + change DataEncode.encode (cfg.BiTape.left.toList) + = DataEncode.encode ((StackTape.nil : StackTape Symbol).toList) + rw [h_left, StackTape.nil_toList]) + apply PB.ifeq_eq_computes + (bitapeLeft_computes (cfgBitape_computes h_cfg)) + (by rw [h_bitape_left]; exact PB.empty_computesEnc (Option Symbol)) + (PB.listReduceOption_computes + (PB.cons_computesEnc + (bitapeHead_computes (cfgBitape_computes h_cfg)) + (bitapeRight_computes (cfgBitape_computes h_cfg)))) def tmSimulator (input : PB) := finalConfigToOutput (tmMainLoop input.fst.snd (initialConfig input.fst.fst input.snd)) -lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbol] - {tm : SingleTapeTM Symbol} [DataEncode tm.State] [DecidableEq tm.State] +/-- Translate Relation.ReflTransGen, the construct underlying `SingleTapeTM.Outputs`, into +iteration of the step function. -/ +private lemma reflTransGen_iff_exists_iter {α : Type} (step : α → Option α) {x y : α} : + Relation.ReflTransGen (fun a b => step a = some b) x y ↔ + ∃ n, (fun a => ((step a).getD a))^[n] x = y := by + constructor + · intro h + obtain ⟨n, h_relates⟩ := Relation.ReflTransGen.relatesInSteps h + clear h + refine ⟨n, ?_⟩ + induction n generalizing x with + | zero => simpa using h_relates + | succ n ih => + obtain ⟨c, h_step, h_rel⟩ := Relation.RelatesInSteps.succ' h_relates + rw [Function.iterate_succ_apply] + have hc : (step x).getD x = c := by simp [h_step] + simpa [hc] using ih h_rel + · intro h + obtain ⟨n, h⟩ := h + induction n generalizing x with + | zero => + simp only [Function.iterate_zero, id_eq] at h + subst h + exact Relation.ReflTransGen.refl + | succ n ih => + rw [Function.iterate_succ_apply] at h + refine Relation.ReflTransGen.trans ?_ (ih h) + cases hs : step x with + | none => simpa using Relation.ReflTransGen.refl + | some c => + simp only [Option.getD_some] + exact Relation.ReflTransGen.single hs + +omit env [DataEncode Symbol] in +/-- If the totalised step function reaches a halting configuration `y` after `N` iterations, +then it also reaches `y` at the *first* halting index `Nat.find h_halts` (halting configurations +are fixpoints of the totalised step, so the orbit stabilises). This bridges +`reflTransGen_iff_exists_iter` (which gives *some* witness `N`) and `tmMainLoop_computes` (whose +result is indexed by `Nat.find h_halts`). -/ +private lemma iterate_find_state_eq [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} {x y : tm.Cfg} {N : ℕ} + (hN : (fun c => (tm.step c).getD c)^[N] x = y) (hy : y.state = none) + (h_halts : ∃ n, ((fun c => (tm.step c).getD c)^[n] x).state = none) : + (fun c => (tm.step c).getD c)^[Nat.find h_halts] x = y := by + set g : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hg + have halt_fix : ∀ c : tm.Cfg, c.state = none → g c = c := by + intro c hc + obtain ⟨s, t⟩ := c + cases s with + | none => simp [hg] + | some q => simp at hc + have hNw : (g^[N] x).state = none := by rw [hN]; exact hy + have hkN : Nat.find h_halts ≤ N := Nat.find_le hNw + have hfix : g (g^[Nat.find h_halts] x) = g^[Nat.find h_halts] x := + halt_fix _ (Nat.find_spec h_halts) + have heq : g^[N] x = g^[Nat.find h_halts] x := by + conv_lhs => rw [show N = (N - Nat.find h_halts) + Nat.find h_halts by omega, + Function.iterate_add_apply] + exact Function.iterate_fixed hfix (N - Nat.find h_halts) + rw [← heq]; exact hN + +omit env [DataEncode Symbol] in +/-- The output list is recovered from the `BiTape` built by `mk₁`: +its head followed by the right-hand contents, with the padding `none`s removed. -/ +private lemma mk₁_reduceOption (l : List Symbol) : + ((BiTape.mk₁ l).head :: (BiTape.mk₁ l).right.toList).reduceOption = l := by + cases l with + | nil => rfl + | cons h t => + change h :: (t.map Option.some).reduceOption = h :: t + simp only [List.cons.injEq, true_and] + induction t with + | nil => rfl + | cons a s ih => simp [ih] + +lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} [DataEncode tm.State] {p_input : PB} {input output : List Symbol} (h_input : p_input.ComputesEnc env @@ -454,7 +563,30 @@ lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] [DecidableEq Symbo (fun c' => (c', tm.tr q' c'))))), input)) : tm.Outputs input output ↔ (tmSimulator p_input).ComputesEnc env output := by - sorry + constructor + · intro h_outputs + -- Build the initial-configuration computation from the encoded input `((q₀, table), input)`. + have h_cfg := initialConfig_computes (tm := tm) + (PB.fst_ComputesEnc (PB.fst_ComputesEnc h_input)) (PB.snd_ComputesEnc h_input) + -- From `Outputs`, the totalised step reaches `haltCfg output` after some `N` iterations. + obtain ⟨N, hN⟩ := (reflTransGen_iff_exists_iter + tm.step (x := tm.initCfg input) (y := tm.haltCfg output)).mp h_outputs + -- Hence it eventually reaches a halting state, and `tmMainLoop` computes that config. + have h_halts : ∃ n, ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none := + ⟨N, by rw [hN]; rfl⟩ + have h_main : + (tmMainLoop p_input.fst.snd (initialConfig p_input.fst.fst p_input.snd)).ComputesEnc + env (tm.haltCfg output) := by + have := tmMainLoop_computes (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) h_cfg h_halts + rwa [iterate_find_state_eq hN rfl h_halts] at this + -- The simulator extracts the output from the halting configuration's tape. + have h_left : (tm.haltCfg output).BiTape.left.toList = [] := by + cases output <;> rfl + have hval : ((tm.haltCfg output).BiTape.head :: + (tm.haltCfg output).BiTape.right.toList).reduceOption = output := mk₁_reduceOption output + simpa only [hval, tmSimulator] using (finalConfigToOutput_computes h_main).mpr h_left + · intro h_comp + sorry diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index 0e649eaa0..d1f4f40e0 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -148,6 +148,54 @@ lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : (constantEnc a).ComputesEnc env a := by simp [ComputesEnc, constantEnc] +/-- The infinite loop. -/ +def diverge : PB := .while_ (.toPair (.cons .empty .empty) .empty) fun acc => acc + +/-- Inversion for `ProgSem` on a variable: the result is exactly the looked-up value, and the +time charged equals the size of that value. -/ +private lemma progSem_var_inv {σ : List Value} {i : ℕ} {r : Value} {t s : ℕ} + (h : ProgSem σ (.var i) r t s) : r = σ[i]?.getD Value.empty ∧ t = r.size := by + cases h + exact ⟨rfl, rfl⟩ + +/-- Helper for `diverge_not_progSem`: a `while_` loop whose body is the identity closure +`fun acc => acc` never terminates as long as the current accumulator's head is non-empty, +so it has no `WhileSem` derivation. Proved by strong induction on the loop's running time. -/ +private lemma diverge_while_false : ∀ (t_w : ℕ) {σ : List Value} {acc r : Data} {s_w : ℕ}, + WhileSem (.closure (.var σ.length) σ) acc r t_w s_w → + acc.asList.head?.getD (Data.l []) ≠ Data.l [] → False := by + intro t_w + induction t_w using Nat.strong_induction_on with + | _ t_w ih => + intro σ acc r s_w hw h_head + cases hw with + | halt h_stop => exact h_head h_stop + | step h_cont h_app h_rest => + rename_i v t_b s_b t_r s_r + cases h_app with + | mk h_b => + obtain ⟨hval, ht⟩ := progSem_var_inv h_b + have : v = acc := by simpa using hval + subst this + have hpos : 0 < t_b := by rw [ht, Value.size_data]; simp + exact ih t_r (by omega) h_rest h_head + +/-- `diverge` has no `ProgSem` derivation: it genuinely diverges. -/ +lemma diverge_not_progSem {out : Value} {t s : ℕ} : + ¬ ProgSem env (diverge env.length) out t s := by + intro h + cases h with + | while_ h_init h_body h_while => + cases h_body + cases h_init with + | cons h₁ h₂ => exact diverge_while_false _ h_while (by cases h₁; simp) + +lemma diverge_computes {out : Value} : ¬ diverge.Computes env out := by + intro h_div + obtain ⟨t, s, hps⟩ := h_div [] + simp only [List.append_nil, List.length_nil, Nat.add_zero] at hps + exact diverge_not_progSem hps + /-- `foldl f init list`: left fold of `f` (taking `acc` then `el`) over `list`. -/ def foldl (f : PB → PB → PB) (init list : PB) : PB := From 63a1f06d47d081fd1b489c6fcb4cef9e0f5cdede Mon Sep 17 00:00:00 2001 From: crei Date: Fri, 12 Jun 2026 14:30:33 +0200 Subject: [PATCH 08/22] simplify. --- .../Machines/RTM/TMSimulator.lean | 114 ++++++------------ Cslib/Computability/Machines/RTM/Tools.lean | 49 -------- 2 files changed, 40 insertions(+), 123 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 973a3566b..89bf7d04e 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -428,51 +428,24 @@ lemma initialConfig_computes [Inhabited Symbol] [Fintype Symbol] (initialConfig p_q₀ p_input).ComputesEnc env (tm.initCfg input) := PB.toPair_computesEnc (PB.some_ComputesEnc h_q₀) (stringToTape_computes h_input) -/-- Compute the final output from the tape contents. -Note that since the single tape Turing machine requires the "left" part of the tape to be empty, -we need to produce "no output" if the left part of the tape is non-empty. The only way -for us to achieve that is to go into an infinite loop. This makes the semantics theorems a bit -more awkward. -/ +/-- Compute the final output from the tape contents: the symbol under the head followed by the +contents to its right, with blank (`none`) cells removed. + +This is only meaningful for halting configurations whose tape is in canonical (`mk₁`) form, i.e. +with an empty left part — which is exactly the shape of the `haltCfg`s produced by `Outputs`. -/ def finalConfigToOutput (cfg : PB) : PB := - PB.ifEq (bitapeLeft (cfgBitape cfg)) PB.empty - (PB.cons (bitapeHead (cfgBitape cfg)) (bitapeRight (cfgBitape cfg))).listReduceOption - PB.diverge + (PB.cons (bitapeHead (cfgBitape cfg)) (bitapeRight (cfgBitape cfg))).listReduceOption lemma finalConfigToOutput_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {p_cfg : PB} {cfg : tm.Cfg} (h_cfg : p_cfg.ComputesEnc env cfg) : (finalConfigToOutput p_cfg).ComputesEnc env - (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption ↔ - cfg.BiTape.left.toList = [] := by - constructor - · intro h_comp - by_contra h_left - obtain ⟨t, s, hps⟩ := h_comp [] - simp only [List.append_nil, List.length_nil, Nat.add_zero, - finalConfigToOutput, PB.ifEq, PB.empty] at hps - cases hps with - | ifEq_then h_x h_y h_then => - cases h_y - obtain ⟨tbl, sbl, hbl⟩ := (bitapeLeft_computes (cfgBitape_computes h_cfg)) [] - simp only [List.append_nil, List.length_nil, Nat.add_zero] at hbl - injection (ProgSem.det h_x hbl) with e1 - apply h_left - exact (DataEncode_list_eq_nil_iff_nil _).mp (e1.symm) - | ifEq_else h_x h_y hne h_else => exact PB.diverge_not_progSem h_else - · intro h_left - have h_bitape_left : cfg.BiTape.left = StackTape.nil := - DataEncode.h_inj (by - change DataEncode.encode (cfg.BiTape.left.toList) - = DataEncode.encode ((StackTape.nil : StackTape Symbol).toList) - rw [h_left, StackTape.nil_toList]) - apply PB.ifeq_eq_computes - (bitapeLeft_computes (cfgBitape_computes h_cfg)) - (by rw [h_bitape_left]; exact PB.empty_computesEnc (Option Symbol)) - (PB.listReduceOption_computes - (PB.cons_computesEnc - (bitapeHead_computes (cfgBitape_computes h_cfg)) - (bitapeRight_computes (cfgBitape_computes h_cfg)))) + (cfg.BiTape.head :: cfg.BiTape.right.toList).reduceOption := + PB.listReduceOption_computes + (PB.cons_computesEnc + (bitapeHead_computes (cfgBitape_computes h_cfg)) + (bitapeRight_computes (cfgBitape_computes h_cfg))) def tmSimulator (input : PB) := finalConfigToOutput (tmMainLoop input.fst.snd (initialConfig input.fst.fst input.snd)) @@ -517,8 +490,11 @@ are fixpoints of the totalised step, so the orbit stabilises). This bridges `reflTransGen_iff_exists_iter` (which gives *some* witness `N`) and `tmMainLoop_computes` (whose result is indexed by `Nat.find h_halts`). -/ private lemma iterate_find_state_eq [Inhabited Symbol] [Fintype Symbol] - {tm : SingleTapeTM Symbol} {x y : tm.Cfg} {N : ℕ} - (hN : (fun c => (tm.step c).getD c)^[N] x = y) (hy : y.state = none) + {tm : SingleTapeTM Symbol} + {x y : tm.Cfg} + {N : ℕ} + (hN : (fun c => (tm.step c).getD c)^[N] x = y) + (hy : y.state = none) (h_halts : ∃ n, ((fun c => (tm.step c).getD c)^[n] x).state = none) : (fun c => (tm.step c).getD c)^[Nat.find h_halts] x = y := by set g : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with hg @@ -536,7 +512,8 @@ private lemma iterate_find_state_eq [Inhabited Symbol] [Fintype Symbol] conv_lhs => rw [show N = (N - Nat.find h_halts) + Nat.find h_halts by omega, Function.iterate_add_apply] exact Function.iterate_fixed hfix (N - Nat.find h_halts) - rw [← heq]; exact hN + rw [← heq] + exact hN omit env [DataEncode Symbol] in /-- The output list is recovered from the `BiTape` built by `mk₁`: @@ -562,39 +539,28 @@ lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] (q', (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tm.tr q' c'))))), input)) : - tm.Outputs input output ↔ (tmSimulator p_input).ComputesEnc env output := by - constructor - · intro h_outputs - -- Build the initial-configuration computation from the encoded input `((q₀, table), input)`. - have h_cfg := initialConfig_computes (tm := tm) - (PB.fst_ComputesEnc (PB.fst_ComputesEnc h_input)) (PB.snd_ComputesEnc h_input) - -- From `Outputs`, the totalised step reaches `haltCfg output` after some `N` iterations. - obtain ⟨N, hN⟩ := (reflTransGen_iff_exists_iter - tm.step (x := tm.initCfg input) (y := tm.haltCfg output)).mp h_outputs - -- Hence it eventually reaches a halting state, and `tmMainLoop` computes that config. - have h_halts : ∃ n, ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none := - ⟨N, by rw [hN]; rfl⟩ - have h_main : - (tmMainLoop p_input.fst.snd (initialConfig p_input.fst.fst p_input.snd)).ComputesEnc - env (tm.haltCfg output) := by - have := tmMainLoop_computes (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) h_cfg h_halts - rwa [iterate_find_state_eq hN rfl h_halts] at this - -- The simulator extracts the output from the halting configuration's tape. - have h_left : (tm.haltCfg output).BiTape.left.toList = [] := by - cases output <;> rfl - have hval : ((tm.haltCfg output).BiTape.head :: - (tm.haltCfg output).BiTape.right.toList).reduceOption = output := mk₁_reduceOption output - simpa only [hval, tmSimulator] using (finalConfigToOutput_computes h_main).mpr h_left - · intro h_comp - sorry - - - -/- TODO: What is left to do here is - - construct the initial configuration from the input string - - extract the output string from the final configuration. - - and of course prove the resource bounds --/ + tm.Outputs input output → (tmSimulator p_input).ComputesEnc env output := by + intro h_outputs + -- Build the initial-configuration computation from the encoded input `((q₀, table), input)`. + have h_cfg := initialConfig_computes (tm := tm) + (PB.fst_ComputesEnc (PB.fst_ComputesEnc h_input)) (PB.snd_ComputesEnc h_input) + -- From `Outputs`, the totalised step reaches `haltCfg output` after some `N` iterations. + obtain ⟨N, hN⟩ := (reflTransGen_iff_exists_iter + tm.step (x := tm.initCfg input) (y := tm.haltCfg output)).mp h_outputs + -- Hence it eventually reaches a halting state, and `tmMainLoop` computes that config. + have h_halts : ∃ n, ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none := + ⟨N, by rw [hN]; rfl⟩ + have h_main : + (tmMainLoop p_input.fst.snd (initialConfig p_input.fst.fst p_input.snd)).ComputesEnc + env (tm.haltCfg output) := by + have := tmMainLoop_computes (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) h_cfg h_halts + rwa [iterate_find_state_eq hN rfl h_halts] at this + -- The simulator extracts the output from the halting configuration's canonical tape. + have hval : ((tm.haltCfg output).BiTape.head :: + (tm.haltCfg output).BiTape.right.toList).reduceOption = output := mk₁_reduceOption output + simpa only [hval, tmSimulator] using finalConfigToOutput_computes h_main + + end RoseTreeMachine end Turing diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index d1f4f40e0..b3df4ffc4 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -148,55 +148,6 @@ lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : (constantEnc a).ComputesEnc env a := by simp [ComputesEnc, constantEnc] -/-- The infinite loop. -/ -def diverge : PB := .while_ (.toPair (.cons .empty .empty) .empty) fun acc => acc - -/-- Inversion for `ProgSem` on a variable: the result is exactly the looked-up value, and the -time charged equals the size of that value. -/ -private lemma progSem_var_inv {σ : List Value} {i : ℕ} {r : Value} {t s : ℕ} - (h : ProgSem σ (.var i) r t s) : r = σ[i]?.getD Value.empty ∧ t = r.size := by - cases h - exact ⟨rfl, rfl⟩ - -/-- Helper for `diverge_not_progSem`: a `while_` loop whose body is the identity closure -`fun acc => acc` never terminates as long as the current accumulator's head is non-empty, -so it has no `WhileSem` derivation. Proved by strong induction on the loop's running time. -/ -private lemma diverge_while_false : ∀ (t_w : ℕ) {σ : List Value} {acc r : Data} {s_w : ℕ}, - WhileSem (.closure (.var σ.length) σ) acc r t_w s_w → - acc.asList.head?.getD (Data.l []) ≠ Data.l [] → False := by - intro t_w - induction t_w using Nat.strong_induction_on with - | _ t_w ih => - intro σ acc r s_w hw h_head - cases hw with - | halt h_stop => exact h_head h_stop - | step h_cont h_app h_rest => - rename_i v t_b s_b t_r s_r - cases h_app with - | mk h_b => - obtain ⟨hval, ht⟩ := progSem_var_inv h_b - have : v = acc := by simpa using hval - subst this - have hpos : 0 < t_b := by rw [ht, Value.size_data]; simp - exact ih t_r (by omega) h_rest h_head - -/-- `diverge` has no `ProgSem` derivation: it genuinely diverges. -/ -lemma diverge_not_progSem {out : Value} {t s : ℕ} : - ¬ ProgSem env (diverge env.length) out t s := by - intro h - cases h with - | while_ h_init h_body h_while => - cases h_body - cases h_init with - | cons h₁ h₂ => exact diverge_while_false _ h_while (by cases h₁; simp) - -lemma diverge_computes {out : Value} : ¬ diverge.Computes env out := by - intro h_div - obtain ⟨t, s, hps⟩ := h_div [] - simp only [List.append_nil, List.length_nil, Nat.add_zero] at hps - exact diverge_not_progSem hps - - /-- `foldl f init list`: left fold of `f` (taking `acc` then `el`) over `list`. -/ def foldl (f : PB → PB → PB) (init list : PB) : PB := snd (PB.while_ (toPair list init) From a0793fcc4535e842eb07863ec0a2cf94e57918d0 Mon Sep 17 00:00:00 2001 From: crei Date: Fri, 12 Jun 2026 14:31:19 +0200 Subject: [PATCH 09/22] remove unused --- Cslib/Computability/Machines/RTM/Prog.lean | 32 ---------------------- 1 file changed, 32 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index f4bed5423..53db58915 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -181,38 +181,6 @@ inductive WhileSem : Value → Data → Data → ℕ → ℕ → Prop WhileSem bodyVal acc r (t_b + t_r) (max s_b s_r) end -/-- Every `ProgSem` derivation uses strictly positive time. -/ -theorem ProgSem.time_pos {σ : List Value} {p : Prog} {v : Value} {t s : ℕ} - (h : ProgSem σ p v t s) : 0 < t := by - induction p generalizing σ v t s <;> cases h <;> grind [Value.size_pos] - -/-- Every `AppSem` derivation uses strictly positive time. -/ -theorem AppSem.time_pos {f a v : Value} {t s : ℕ} (h : AppSem f a v t s) : 0 < t := by - cases h with - | mk hb => exact ProgSem.time_pos hb - -/-- Every `WhileSem` derivation uses strictly positive time. -/ -theorem WhileSem.time_pos {b : Value} {acc r : Data} {t s : ℕ} (h : WhileSem b acc r t s) : - 0 < t := by - cases h with - | halt => exact Data.size_le - | step hc hap hr => have := AppSem.time_pos hap; omega - -/-- The value produced by `ProgSem` is uniquely determined by the program and environment: -evaluation is deterministic (the time and space may in principle differ, but the result -cannot). - -TODO -/ -theorem ProgSem.det {σ : List Value} {p : Prog} {v₁ v₂ : Value} {t₁ s₁ t₂ s₂ : ℕ} - (h₁ : ProgSem σ p v₁ t₁ s₁) (h₂ : ProgSem σ p v₂ t₂ s₂) : v₁ = v₂ := by - induction t₁ using Nat.strong_induction_on generalizing σ p v₁ v₂ s₁ t₂ s₂ - rename_i t ih - cases p with - | var i => - have : v₂ = (σ[i]?.getD Value.empty) := by sorry --simp_all [h₂] - sorry - | _ => sorry - /-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/ def Prog.ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop := ProgSem [.data x] p (.data y) t s From 354ce89f8ea2e41295002224244f97fbac9336b1 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 16 Jun 2026 17:40:55 +0200 Subject: [PATCH 10/22] Successor and addition of binary numbers. --- Cslib/Computability/Machines/RTM/Tools.lean | 345 ++++++++++++++++++++ 1 file changed, 345 insertions(+) diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index b3df4ffc4..b884a4852 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -148,6 +148,70 @@ lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : (constantEnc a).ComputesEnc env a := by simp [ComputesEnc, constantEnc] + +def isEq (x y : PB) : PB := + ifEq x y (constantEnc true) (constantEnc false) + +lemma isEq_computes {α : Type} [DecidableEq α] [DataEncode α] + {a b : α} {pa pb : PB} + (ha : pa.ComputesEnc env a) (hb : pb.ComputesEnc env b) : + (isEq pa pb).ComputesEnc env (a == b) := by + by_cases h : a = b + · rw [show (a == b) = true by simp [h]] + exact PB.ifeq_eq_computes ha (h ▸ hb) (constantEnc_computesEnc (a := true)) + · rw [show (a == b) = false by simp [h]] + exact PB.ifeq_ne_computes ha hb (fun heq => h (DataEncode.h_inj heq)) + (constantEnc_computesEnc (a := false)) + +def boolNot (x : PB) : PB := + isEq x (constantEnc false) + +lemma boolNot_computes {x : PB} {b : Bool} (hx : x.ComputesEnc env b) : + (boolNot x).ComputesEnc env (!b) := by + rw [show not b = (b == false) by simp] + exact isEq_computes hx (constantEnc_computesEnc (a := false)) + +def boolXor (x y : PB) : PB := + boolNot (isEq x y) + +lemma boolXor_computes {x y : PB} {b1 b2 : Bool} + (hx : x.ComputesEnc env b1) (hy : y.ComputesEnc env b2) : + (boolXor x y).ComputesEnc env (b1 ^^ b2) := by + exact boolNot_computes (isEq_computes hx hy) + +def boolIte (cond thenBranch elseBranch : PB) : PB := + ifEq cond (constantEnc true) thenBranch elseBranch + +lemma boolIte_computes {p_cond p_then p_else : PB} {cond : Bool} {x y : α} + (h_cond : p_cond.ComputesEnc env cond) + (h_then : p_then.ComputesEnc env x) + (h_else : p_else.ComputesEnc env y) : + (boolIte p_cond p_then p_else).ComputesEnc env (if cond then x else y) := by + by_cases h : cond + · rw [if_pos h] + exact ifeq_eq_computes h_cond (h ▸ constantEnc_computesEnc (a := true)) h_then + · rw [if_neg h] + refine ifeq_ne_computes h_cond (constantEnc_computesEnc (a := true)) ?_ h_else + simp [h, DataEncode.h_inj.eq_iff] + +def boolAnd (x y : PB) : PB := + boolIte x y (constantEnc false) + +lemma boolAnd_computes {x y : PB} {b1 b2 : Bool} + (hx : x.ComputesEnc env b1) (hy : y.ComputesEnc env b2) : + (boolAnd x y).ComputesEnc env (b1 && b2) := by + rw [show (b1 && b2) = if b1 then b2 else false by simp] + exact boolIte_computes hx hy (constantEnc_computesEnc (a := false)) + +def boolOr (x y : PB) : PB := + boolIte x (constantEnc true) y + +lemma boolOr_computes {x y : PB} {b1 b2 : Bool} + (hx : x.ComputesEnc env b1) (hy : y.ComputesEnc env b2) : + (boolOr x y).ComputesEnc env (b1 || b2) := by + rw [show (b1 || b2) = if b1 then true else b2 by simp] + exact boolIte_computes hx (constantEnc_computesEnc (a := true)) hy + /-- `foldl f init list`: left fold of `f` (taking `acc` then `el`) over `list`. -/ def foldl (f : PB → PB → PB) (init list : PB) : PB := snd (PB.while_ (toPair list init) @@ -208,6 +272,19 @@ lemma reverse_computes {p : PB} {l : List α} (h : p.ComputesEnc env l) : intro env p_tl p_hd tl hd h_tl h_hd exact cons_computesEnc h_hd h_tl +def listAppend (x y : PB) : PB := + foldl (fun acc el => cons el acc) y (reverse x) + +lemma listAppend_computes {p_x p_y : PB} {l1 l2 : List α} + (h_x : p_x.ComputesEnc env l1) (h_y : p_y.ComputesEnc env l2) : + (listAppend p_x p_y).ComputesEnc env (l1 ++ l2) := by + have h_eq : l1 ++ l2 = l1.reverse.foldl (fun acc el => el :: acc) l2 := by + simp + rw [h_eq] + apply foldl_computes h_y (reverse_computes h_x) ?_ + intro e p_acc p_el acc el h_acc h_el + exact cons_computesEnc h_el h_acc + /-- Models `List.map`. -/ def listMap (x : PB) (f : PB → PB) : PB := reverse (foldl (fun acc el => cons (f el) acc) empty x) @@ -265,6 +342,274 @@ lemma listHeadOption_computes {p : PB} {l : List α} (h : p.ComputesEnc env l) : apply PB.elim_cons_computes h (PB.computesFun₂_branch2 (fun ext => ?_)) refine PB.cons_computes (var_computes_fresh ext _) empty_computes +/-- The fold step used by `succBin`: given the running `(carry, acc)` and the next `bit`, emit the +new carry `carry && bit` and prepend the output bit `carry ^^ bit`. -/ +def succBinStep (p : Bool × List Bool) (bit : Bool) : Bool × List Bool := + (p.1 && bit, (p.1 ^^ bit) :: p.2) + +def succBin (n : List Bool) : List Bool := + let (final_carry, rev_res) := n.foldl succBinStep (true, []) + (if final_carry then true :: rev_res else rev_res).reverse + +/-- With carry `false`, the fold never produces a carry and simply reverses the remaining bits onto +the accumulator. -/ +lemma foldl_succBinStep_false (bs : List Bool) (acc : List Bool) : + bs.foldl succBinStep (false, acc) = (false, bs.reverse ++ acc) := by + induction bs generalizing acc with + | nil => simp + | cons hd tl ih => simp [succBinStep, ih (hd :: acc)] + +/-- The accumulator threads through the fold independently of the computed carry and output bits. -/ +lemma foldl_succBinStep_acc (bs : List Bool) (c : Bool) (acc : List Bool) : + bs.foldl succBinStep (c, acc) + = ((bs.foldl succBinStep (c, [])).1, (bs.foldl succBinStep (c, [])).2 ++ acc) := by + induction bs generalizing c acc with + | nil => simp + | cons hd tl ih => + rw [List.foldl_cons, show succBinStep (c, acc) hd = (c && hd, (c ^^ hd) :: acc) from rfl, + ih (c && hd) ((c ^^ hd) :: acc), List.foldl_cons, + show succBinStep (c, ([] : List Bool)) hd = (c && hd, [c ^^ hd]) from rfl, + ih (c && hd) [c ^^ hd]] + simp + +lemma succ_bin_correct (n : ℕ) : succBin n.bits = (n + 1).bits := by + induction n using Nat.binaryRec' with + | zero => rw [Nat.zero_bits]; rfl + | bit b m hb ih => + rw [Nat.bits_append_bit m b hb] + unfold succBin + cases b with + | false => + rw [List.foldl_cons, + show succBinStep (true, []) false = (false, [true]) from rfl, + foldl_succBinStep_false, Nat.bit_false_apply, Nat.bit1_bits] + simp + | true => + rw [List.foldl_cons, + show succBinStep (true, []) true = (true, [false]) from rfl, + foldl_succBinStep_acc, Nat.bit_true_apply, + show 2 * m + 1 + 1 = 2 * (m + 1) from by omega, + Nat.bit0_bits (m + 1) (Nat.succ_ne_zero m), ← ih] + unfold succBin + dsimp only + split <;> simp [List.reverse_append] + +def succ_foldl_body (st bit : PB) : PB := + let carry := st.fst + let acc := st.snd + toPair (boolAnd carry bit) (cons (boolXor carry bit) acc) + +/-- Compute ℕ.succ (in its default binary encoding). -/ +def succ (x : PB) : PB := + let loop_result := foldl + succ_foldl_body + (toPair (constantEnc true) empty) + x + let final_carry := loop_result.fst + let result_rev := loop_result.snd + -- If final carry, prepend 1; otherwise just reverse back + reverse (boolIte final_carry (cons (constantEnc true) result_rev) result_rev) + +/-- The `succ` program computes `succBin` on the underlying bit list, independently of whether +that list is a canonical ℕ encoding. -/ +lemma succ_computes_list {p : PB} {l : List Bool} (h : p.ComputesEnc env l) : + (succ p).ComputesEnc env (succBin l) := by + have h_body : ∀ {e : List Value} {pa pb : PB} {a : Bool × List Bool} {b : Bool}, + pa.ComputesEnc e a → pb.ComputesEnc e b → + (succ_foldl_body pa pb).ComputesEnc e + ((fun (st : Bool × List Bool) bit => (st.1 && bit, (st.1 ^^ bit) :: st.2)) a b) := by + intro e pa pb a b ha hb + exact toPair_computesEnc (boolAnd_computes (fst_ComputesEnc ha) hb) + (cons_computesEnc (boolXor_computes (fst_ComputesEnc ha) hb) (snd_ComputesEnc ha)) + have h_fold := foldl_computes + (toPair_computesEnc (constantEnc_computesEnc (a := true)) (empty_computesEnc Bool)) + h h_body + apply reverse_computes (boolIte_computes (fst_ComputesEnc h_fold) ?_ (snd_ComputesEnc h_fold)) + exact cons_computesEnc constantEnc_computesEnc (snd_ComputesEnc h_fold) + +lemma succ_computes {p : PB} {n : ℕ} (h : p.ComputesEnc env n) : + (succ p).ComputesEnc env (n + 1) := by + change (succ p).ComputesEnc env (n + 1).bits + rw [← succ_bin_correct] + exact succ_computes_list h + +/-- Computes addition of three bits, returning `(sum, carry)`. -/ +def fullAdder (x y carry : Bool) : Bool × Bool := + (x ^^ y ^^ carry, (x && y) || (carry && (x ^^ y))) + +/-- One ripple-carry step. The state `(toAdd, carry, acc)` carries the remaining bits of the second +addend (`toAdd`), the running `carry`, and the reversed output bits (`acc`). Each step consumes the +next bit of the first addend together with the front bit of `toAdd` (or `false` once `toAdd` is +exhausted), emitting the sum bit onto `acc`. -/ +def addBinStep (p : List Bool × Bool × List Bool) (bit : Bool) : List Bool × Bool × List Bool := + match p.1 with + | [] => ([], (fullAdder false bit p.2.1).2, (fullAdder false bit p.2.1).1 :: p.2.2) + | a :: as => (as, (fullAdder a bit p.2.1).2, (fullAdder a bit p.2.1).1 :: p.2.2) + +/-- Adds the bit lists `x` and `y` with an incoming `carry`. -/ +def addCarry (carry : Bool) (x y : List Bool) : List Bool := + let (toAdd, finalCarry, rev) := x.foldl addBinStep (y, carry, []) + rev.reverse ++ (if finalCarry then succBin toAdd else toAdd) + +def addBin (x y : List Bool) : List Bool := addCarry false x y + +/-- The accumulator threads through the `addBinStep` fold independently of the remaining addend and +carry. -/ +lemma foldl_addBinStep_acc (xs ys : List Bool) (c : Bool) (acc : List Bool) : + xs.foldl addBinStep (ys, c, acc) + = ((xs.foldl addBinStep (ys, c, [])).1, (xs.foldl addBinStep (ys, c, [])).2.1, + (xs.foldl addBinStep (ys, c, [])).2.2 ++ acc) := by + induction xs generalizing ys c acc with + | nil => simp + | cons hd tl ih => + rw [List.foldl_cons, List.foldl_cons] + cases ys with + | nil => + simp only [addBinStep] + rw [ih [] _ _, ih [] _ [_]] + simp + | cons d ds => + simp only [addBinStep] + rw [ih ds _ _, ih ds _ [_]] + simp + +/-- Evaluating `addBinStep` on `y.bits` exposes the next sum bit and carry via `fullAdder`, +independently of whether `y` is zero. -/ +lemma addBinStep_bits (y : ℕ) (c b : Bool) (acc : List Bool) : + addBinStep (y.bits, c, acc) b + = (y.div2.bits, (fullAdder (Nat.bodd y) b c).2, (fullAdder (Nat.bodd y) b c).1 :: acc) := by + cases y using Nat.binaryRec' with + | zero => simp [addBinStep, Nat.zero_bits] + | bit d m hd => rw [Nat.bits_append_bit m d hd]; simp [addBinStep] + +/-- Peeling the first bit of the first addend in `addCarry`, when the second addend is `y.bits`. -/ +lemma addCarry_cons_bits (c b : Bool) (xs : List Bool) (y : ℕ) : + addCarry c (b :: xs) y.bits + = (fullAdder (Nat.bodd y) b c).1 + :: addCarry (fullAdder (Nat.bodd y) b c).2 xs y.div2.bits := by + unfold addCarry + rw [List.foldl_cons, addBinStep_bits, + foldl_addBinStep_acc xs y.div2.bits (fullAdder (Nat.bodd y) b c).2 + [(fullAdder (Nat.bodd y) b c).1]] + simp [List.reverse_append] + +lemma addCarry_correct (c : Bool) (x y : ℕ) : + addCarry c x.bits y.bits = (x + y + c.toNat).bits := by + induction x using Nat.binaryRec' generalizing c y with + | zero => cases c <;> simp [addCarry, Nat.zero_bits, succ_bin_correct] + | bit b m hb ih => + rw [Nat.bits_append_bit m b hb, addCarry_cons_bits, ih] + have hy := Nat.bodd_add_div2 y + rw [show Nat.bit b m + y + c.toNat + = Nat.bit (fullAdder (Nat.bodd y) b c).1 + (m + y.div2 + (fullAdder (Nat.bodd y) b c).2.toNat) from by + simp only [Nat.bit_val, fullAdder] + cases b <;> cases c <;> cases hbd : Nat.bodd y <;> simp_all <;> omega] + rw [Nat.bits_append_bit] + rintro hzero + have hb' : b = true := hb (by omega) + subst hb' + simp only [fullAdder] at hzero ⊢ + cases c <;> cases hbd : Nat.bodd y <;> simp_all + +lemma addBin_correct (x y : ℕ) : addBin x.bits y.bits = (x + y).bits := by + rw [addBin, addCarry_correct] + simp + +/-- The sum bit of a full adder, as a builder. -/ +def addSumPB (a bit carry : PB) : PB := boolXor (boolXor a bit) carry + +/-- The carry-out bit of a full adder, as a builder. -/ +def addCarryPB (a bit carry : PB) : PB := + boolOr (boolAnd a bit) (boolAnd carry (boolXor a bit)) + +lemma addSumPB_computes {pa pbit pc : PB} {av bv cv : Bool} + (ha : pa.ComputesEnc env av) (hbit : pbit.ComputesEnc env bv) + (hc : pc.ComputesEnc env cv) : + (addSumPB pa pbit pc).ComputesEnc env (fullAdder av bv cv).1 := by + simp only [fullAdder, addSumPB] + exact boolXor_computes (boolXor_computes ha hbit) hc + +lemma addCarryPB_computes {pa pbit pc : PB} {av bv cv : Bool} + (ha : pa.ComputesEnc env av) (hbit : pbit.ComputesEnc env bv) + (hc : pc.ComputesEnc env cv) : + (addCarryPB pa pbit pc).ComputesEnc env (fullAdder av bv cv).2 := by + simp only [fullAdder, addCarryPB] + exact boolOr_computes (boolAnd_computes ha hbit) + (boolAnd_computes hc (boolXor_computes ha hbit)) + +/-- The fold body implementing `addBinStep`. The state encodes the triple `(toAdd, carry, acc)`: +consume the front bit of `toAdd` (or `false` once it is exhausted) together with the current bit +`bit` of the first addend, emitting the sum bit onto `acc` and threading the new carry. -/ +def add_foldl_body (st bit : PB) : PB := + elim st.fst + (toPair empty + (toPair (addCarryPB (constantEnc false) bit st.snd.fst) + (cons (addSumPB (constantEnc false) bit st.snd.fst) st.snd.snd))) + (fun hd tl => + toPair tl + (toPair (addCarryPB hd bit st.snd.fst) + (cons (addSumPB hd bit st.snd.fst) st.snd.snd))) + +/-- Compute binary addition in the default ℕ encoding. Mirrors `addBin`/`addCarry`: fold +`add_foldl_body` over the first addend `x` starting from state `(y, false, [])`, then reverse the +emitted bits and append the leftover high bits (incremented when a final carry remains). -/ +def add (x y : PB) : PB := + let loop := foldl add_foldl_body (toPair y (toPair (constantEnc false) empty)) x + listAppend (reverse loop.snd.snd) (boolIte loop.snd.fst (succ loop.fst) loop.fst) + +lemma add_computes {px py : PB} {x y : ℕ} + (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : + (add px py).ComputesEnc env (x + y) := by + have hx' : px.ComputesEnc env x.bits := hx + have hy' : py.ComputesEnc env y.bits := hy + have h_body : ∀ {e : List Value} {pa pb : PB} + {a : List Bool × Bool × List Bool} {b : Bool}, + pa.ComputesEnc e a → pb.ComputesEnc e b → + (add_foldl_body pa pb).ComputesEnc e (addBinStep a b) := by + intro e pa pb a b ha hb + obtain ⟨toAdd, carry, acc⟩ := a + cases toAdd with + | nil => + refine elim_nil_computes (fst_ComputesEnc ha) ?_ + exact toPair_computesEnc (empty_computesEnc Bool) + (toPair_computesEnc + (addCarryPB_computes constantEnc_computesEnc hb + (fst_ComputesEnc (snd_ComputesEnc ha))) + (cons_computesEnc + (addSumPB_computes constantEnc_computesEnc hb + (fst_ComputesEnc (snd_ComputesEnc ha))) + (snd_ComputesEnc (snd_ComputesEnc ha)))) + | cons hd tl => + refine elim_cons_computes (fst_ComputesEnc ha) (computesFun₂_branch2 ?_) + intro ext + have ha' := (ha.extend ext).extend + [Value.data (DataEncode.encode hd), Value.data (DataEncode.encode tl)] + have hb' := (hb.extend ext).extend + [Value.data (DataEncode.encode hd), Value.data (DataEncode.encode tl)] + exact toPair_computesEnc (var_computes_fresh2 ext []) + (toPair_computesEnc + (addCarryPB_computes (var_computes_fresh ext _) hb' + (fst_ComputesEnc (snd_ComputesEnc ha'))) + (cons_computesEnc + (addSumPB_computes (var_computes_fresh ext _) hb' + (fst_ComputesEnc (snd_ComputesEnc ha'))) + (snd_ComputesEnc (snd_ComputesEnc ha')))) + have h_fold := foldl_computes + (toPair_computesEnc hy' + (toPair_computesEnc (constantEnc_computesEnc (a := false)) (empty_computesEnc Bool))) + hx' h_body + change (add px py).ComputesEnc env (x + y).bits + rw [← addBin_correct] + unfold addBin addCarry + generalize hE : x.bits.foldl addBinStep (y.bits, false, []) = E at h_fold ⊢ + obtain ⟨tA, fC, rv⟩ := E + unfold add + exact listAppend_computes (reverse_computes (snd_ComputesEnc (snd_ComputesEnc h_fold))) + (boolIte_computes (fst_ComputesEnc (snd_ComputesEnc h_fold)) + (succ_computes_list (fst_ComputesEnc h_fold)) + (fst_ComputesEnc h_fold)) + -- Evaluate a function `f` at `arg` where the function is given as a graph (list of pairs). -- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise. def evalFunGraph (graph : PB) (arg : PB) : PB := From 98d0bfc4768f2c15011873959172db8fed4630e9 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 16 Jun 2026 18:03:19 +0200 Subject: [PATCH 11/22] Addition and multiplication. --- Cslib/Computability/Machines/RTM/Tools.lean | 115 ++++++++++++++++++-- 1 file changed, 105 insertions(+), 10 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index b884a4852..f407c99e2 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -558,11 +558,11 @@ def add (x y : PB) : PB := let loop := foldl add_foldl_body (toPair y (toPair (constantEnc false) empty)) x listAppend (reverse loop.snd.snd) (boolIte loop.snd.fst (succ loop.fst) loop.fst) -lemma add_computes {px py : PB} {x y : ℕ} - (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : - (add px py).ComputesEnc env (x + y) := by - have hx' : px.ComputesEnc env x.bits := hx - have hy' : py.ComputesEnc env y.bits := hy +/-- The `add` program computes `addBin` on the underlying bit lists, for any lists (not just +canonical ℕ encodings). -/ +lemma add_computes_list {px py : PB} {l1 l2 : List Bool} + (hx : px.ComputesEnc env l1) (hy : py.ComputesEnc env l2) : + (add px py).ComputesEnc env (addBin l1 l2) := by have h_body : ∀ {e : List Value} {pa pb : PB} {a : List Bool × Bool × List Bool} {b : Bool}, pa.ComputesEnc e a → pb.ComputesEnc e b → @@ -596,13 +596,11 @@ lemma add_computes {px py : PB} {x y : ℕ} (fst_ComputesEnc (snd_ComputesEnc ha'))) (snd_ComputesEnc (snd_ComputesEnc ha')))) have h_fold := foldl_computes - (toPair_computesEnc hy' + (toPair_computesEnc hy (toPair_computesEnc (constantEnc_computesEnc (a := false)) (empty_computesEnc Bool))) - hx' h_body - change (add px py).ComputesEnc env (x + y).bits - rw [← addBin_correct] + hx h_body unfold addBin addCarry - generalize hE : x.bits.foldl addBinStep (y.bits, false, []) = E at h_fold ⊢ + generalize hE : l1.foldl addBinStep (l2, false, []) = E at h_fold ⊢ obtain ⟨tA, fC, rv⟩ := E unfold add exact listAppend_computes (reverse_computes (snd_ComputesEnc (snd_ComputesEnc h_fold))) @@ -610,6 +608,103 @@ lemma add_computes {px py : PB} {x y : ℕ} (succ_computes_list (fst_ComputesEnc h_fold)) (fst_ComputesEnc h_fold)) +lemma add_computes {px py : PB} {x y : ℕ} + (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : + (add px py).ComputesEnc env (x + y) := by + change (add px py).ComputesEnc env (x + y).bits + rw [← addBin_correct] + exact add_computes_list hx hy + +/-- Doubles a binary number (the math-level `· * 2`), keeping the canonical encoding: prepend a +`false` low bit, except for `0` (the empty list) which stays empty. -/ +def doubleBin (l : List Bool) : List Bool := + match l with + | [] => [] + | _ => false :: l + +lemma doubleBin_bits (Y : ℕ) : doubleBin Y.bits = (2 * Y).bits := by + cases Y using Nat.binaryRec' with + | zero => simp [doubleBin, Nat.zero_bits] + | bit b m hb => + have hYne : Nat.bit b m ≠ 0 := Nat.bit_ne_zero_iff.mpr hb + rw [Nat.bits_append_bit m b hb, Nat.bit0_bits _ hYne, Nat.bits_append_bit m b hb] + rfl + +/-- One shift-and-add step of binary multiplication. The state `(shiftedY, product)` holds the +second addend shifted left by the current position and the running product. Each step doubles +`shiftedY` and, when the current bit of the multiplier is set, adds `shiftedY` into `product`. -/ +def mulBinStep (st : List Bool × List Bool) (bit : Bool) : List Bool × List Bool := + (doubleBin st.1, if bit then addBin st.2 st.1 else st.2) + +/-- Multiplies the bit lists `x` and `y` by folding `mulBinStep` over `x`. -/ +def mulBin (x y : List Bool) : List Bool := + (x.foldl mulBinStep (y, [])).2 + +/-- Generalised correctness of the multiplication fold: folding `mulBinStep` over `n.bits` +starting from `(Y, P)` accumulates `P + n * Y` into the product component. -/ +lemma mulBin_foldl (n Y P : ℕ) : + (n.bits.foldl mulBinStep (Y.bits, P.bits)).2 = (P + n * Y).bits := by + induction n using Nat.binaryRec' generalizing Y P with + | zero => simp [Nat.zero_bits] + | bit b m hb ih => + rw [Nat.bits_append_bit m b hb, List.foldl_cons] + have hstep : mulBinStep (Y.bits, P.bits) b + = ((2 * Y).bits, (if b then P + Y else P).bits) := by + cases b <;> simp [mulBinStep, doubleBin_bits, addBin_correct] + rw [hstep, ih] + congr 1 + have hb2 : (if b then P + Y else P) = P + b.toNat * Y := by cases b <;> simp + rw [hb2, Nat.bit_val, ← Nat.mul_assoc, Nat.mul_comm m 2, Nat.add_mul] + omega + +lemma mulBin_correct (x y : ℕ) : mulBin x.bits y.bits = (x * y).bits := by + have h := mulBin_foldl x y 0 + rw [Nat.zero_bits] at h + unfold mulBin + rw [h] + simp + +/-- The PB builder doubling a binary number, implementing `doubleBin`. -/ +def doublePB (l : PB) : PB := + elim l empty (fun hd tl => cons (constantEnc false) (cons hd tl)) + +lemma doublePB_computes {p : PB} {l : List Bool} (h : p.ComputesEnc env l) : + (doublePB p).ComputesEnc env (doubleBin l) := by + cases l with + | nil => exact elim_nil_computes h (empty_computesEnc Bool) + | cons hd tl => + refine elim_cons_computes h (computesFun₂_branch2 ?_) + intro ext + exact cons_computesEnc constantEnc_computesEnc + (cons_computesEnc (var_computes_fresh ext _) (var_computes_fresh2 ext [])) + +/-- The fold body implementing `mulBinStep`: double the shifted second addend and conditionally +add it to the running product. -/ +def mulFoldlBody (st bit : PB) : PB := + toPair (doublePB st.fst) (boolIte bit (add st.snd st.fst) st.snd) + +/-- Compute binary multiplication in the default ℕ encoding. Fold `mul_foldl_body` over the first +factor `x`, starting from state `(y, [])`; the product component of the final state is the result. +The second factor `y` is copied into the accumulator (rather than read from the environment). -/ +def mul (x y : PB) : PB := + snd (foldl mulFoldlBody (toPair y empty) x) + +lemma mul_computes {px py : PB} {x y : ℕ} + (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : + (mul px py).ComputesEnc env (x * y) := by + have h_body : ∀ {e : List Value} {pa pb : PB} + {a : List Bool × List Bool} {b : Bool}, + pa.ComputesEnc e a → pb.ComputesEnc e b → + (mulFoldlBody pa pb).ComputesEnc e (mulBinStep a b) := by + intro e pa pb a b ha hb + refine toPair_computesEnc (doublePB_computes (fst_ComputesEnc ha)) ?_ + exact boolIte_computes hb + (add_computes_list (snd_ComputesEnc ha) (fst_ComputesEnc ha)) (snd_ComputesEnc ha) + change (mul px py).ComputesEnc env (x * y).bits + rw [← mulBin_correct] + exact snd_ComputesEnc (foldl_computes + (toPair_computesEnc hy (empty_computesEnc Bool)) hx h_body) + -- Evaluate a function `f` at `arg` where the function is given as a graph (list of pairs). -- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise. def evalFunGraph (graph : PB) (arg : PB) : PB := From 79b071517acd0b344c028eb80055349cd2f21099 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 16 Jun 2026 18:06:51 +0200 Subject: [PATCH 12/22] Move arithmetic. --- Cslib/Computability/Machines/RTM/Arith.lean | 405 ++++++++++++++++++++ Cslib/Computability/Machines/RTM/Tools.lean | 363 ------------------ 2 files changed, 405 insertions(+), 363 deletions(-) create mode 100644 Cslib/Computability/Machines/RTM/Arith.lean diff --git a/Cslib/Computability/Machines/RTM/Arith.lean b/Cslib/Computability/Machines/RTM/Arith.lean new file mode 100644 index 000000000..a714ef409 --- /dev/null +++ b/Cslib/Computability/Machines/RTM/Arith.lean @@ -0,0 +1,405 @@ +/- +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.RTM.Tools + +/-! # Binary arithmetic for rose tree machines + +Program builders computing arithmetic on natural numbers in their default LSB-first binary +encoding (`Nat.bits`), together with their semantics. Each operation comes with a math-level +correctness lemma (on bit lists) and a `ComputesEnc` semantics proof for the corresponding +program builder. + +## Main definitions + +- `PB.succ` - the successor `n + 1` +- `PB.add` - binary addition `x + y` +- `PB.mul` - binary multiplication `x * y` + +-/ + +@[expose] public section + +namespace Turing + +namespace RoseTreeMachine + +namespace PB + +variable {env : List Value} +variable {α : Type} [DataEncode α] +variable {β : Type} [DataEncode β] + +/-- The fold step used by `succBin`: given the running `(carry, acc)` and the next `bit`, emit the +new carry `carry && bit` and prepend the output bit `carry ^^ bit`. -/ +def succBinStep (p : Bool × List Bool) (bit : Bool) : Bool × List Bool := + (p.1 && bit, (p.1 ^^ bit) :: p.2) + +def succBin (n : List Bool) : List Bool := + let (final_carry, rev_res) := n.foldl succBinStep (true, []) + (if final_carry then true :: rev_res else rev_res).reverse + +/-- With carry `false`, the fold never produces a carry and simply reverses the remaining bits onto +the accumulator. -/ +lemma foldl_succBinStep_false (bs : List Bool) (acc : List Bool) : + bs.foldl succBinStep (false, acc) = (false, bs.reverse ++ acc) := by + induction bs generalizing acc with + | nil => simp + | cons hd tl ih => simp [succBinStep, ih (hd :: acc)] + +/-- The accumulator threads through the fold independently of the computed carry and output bits. -/ +lemma foldl_succBinStep_acc (bs : List Bool) (c : Bool) (acc : List Bool) : + bs.foldl succBinStep (c, acc) + = ((bs.foldl succBinStep (c, [])).1, (bs.foldl succBinStep (c, [])).2 ++ acc) := by + induction bs generalizing c acc with + | nil => simp + | cons hd tl ih => + rw [List.foldl_cons, show succBinStep (c, acc) hd = (c && hd, (c ^^ hd) :: acc) from rfl, + ih (c && hd) ((c ^^ hd) :: acc), List.foldl_cons, + show succBinStep (c, ([] : List Bool)) hd = (c && hd, [c ^^ hd]) from rfl, + ih (c && hd) [c ^^ hd]] + simp + +lemma succ_bin_correct (n : ℕ) : succBin n.bits = (n + 1).bits := by + induction n using Nat.binaryRec' with + | zero => rw [Nat.zero_bits]; rfl + | bit b m hb ih => + rw [Nat.bits_append_bit m b hb] + unfold succBin + cases b with + | false => + rw [List.foldl_cons, + show succBinStep (true, []) false = (false, [true]) from rfl, + foldl_succBinStep_false, Nat.bit_false_apply, Nat.bit1_bits] + simp + | true => + rw [List.foldl_cons, + show succBinStep (true, []) true = (true, [false]) from rfl, + foldl_succBinStep_acc, Nat.bit_true_apply, + show 2 * m + 1 + 1 = 2 * (m + 1) from by omega, + Nat.bit0_bits (m + 1) (Nat.succ_ne_zero m), ← ih] + unfold succBin + dsimp only + split <;> simp [List.reverse_append] + +def succ_foldl_body (st bit : PB) : PB := + let carry := st.fst + let acc := st.snd + toPair (boolAnd carry bit) (cons (boolXor carry bit) acc) + +/-- Compute ℕ.succ (in its default binary encoding). -/ +def succ (x : PB) : PB := + let loop_result := foldl + succ_foldl_body + (toPair (constantEnc true) empty) + x + let final_carry := loop_result.fst + let result_rev := loop_result.snd + -- If final carry, prepend 1; otherwise just reverse back + reverse (boolIte final_carry (cons (constantEnc true) result_rev) result_rev) + +/-- The `succ` program computes `succBin` on the underlying bit list, independently of whether +that list is a canonical ℕ encoding. -/ +lemma succ_computes_list {p : PB} {l : List Bool} (h : p.ComputesEnc env l) : + (succ p).ComputesEnc env (succBin l) := by + have h_body : ∀ {e : List Value} {pa pb : PB} {a : Bool × List Bool} {b : Bool}, + pa.ComputesEnc e a → pb.ComputesEnc e b → + (succ_foldl_body pa pb).ComputesEnc e + ((fun (st : Bool × List Bool) bit => (st.1 && bit, (st.1 ^^ bit) :: st.2)) a b) := by + intro e pa pb a b ha hb + exact toPair_computesEnc (boolAnd_computes (fst_ComputesEnc ha) hb) + (cons_computesEnc (boolXor_computes (fst_ComputesEnc ha) hb) (snd_ComputesEnc ha)) + have h_fold := foldl_computes + (toPair_computesEnc (constantEnc_computesEnc (a := true)) (empty_computesEnc Bool)) + h h_body + apply reverse_computes (boolIte_computes (fst_ComputesEnc h_fold) ?_ (snd_ComputesEnc h_fold)) + exact cons_computesEnc constantEnc_computesEnc (snd_ComputesEnc h_fold) + +lemma succ_computes {p : PB} {n : ℕ} (h : p.ComputesEnc env n) : + (succ p).ComputesEnc env (n + 1) := by + change (succ p).ComputesEnc env (n + 1).bits + rw [← succ_bin_correct] + exact succ_computes_list h + +/-- Computes addition of three bits, returning `(sum, carry)`. -/ +def fullAdder (x y carry : Bool) : Bool × Bool := + (x ^^ y ^^ carry, (x && y) || (carry && (x ^^ y))) + +/-- One ripple-carry step. The state `(toAdd, carry, acc)` carries the remaining bits of the second +addend (`toAdd`), the running `carry`, and the reversed output bits (`acc`). Each step consumes the +next bit of the first addend together with the front bit of `toAdd` (or `false` once `toAdd` is +exhausted), emitting the sum bit onto `acc`. -/ +def addBinStep (p : List Bool × Bool × List Bool) (bit : Bool) : List Bool × Bool × List Bool := + match p.1 with + | [] => ([], (fullAdder false bit p.2.1).2, (fullAdder false bit p.2.1).1 :: p.2.2) + | a :: as => (as, (fullAdder a bit p.2.1).2, (fullAdder a bit p.2.1).1 :: p.2.2) + +/-- Adds the bit lists `x` and `y` with an incoming `carry`. -/ +def addCarry (carry : Bool) (x y : List Bool) : List Bool := + let (toAdd, finalCarry, rev) := x.foldl addBinStep (y, carry, []) + rev.reverse ++ (if finalCarry then succBin toAdd else toAdd) + +def addBin (x y : List Bool) : List Bool := addCarry false x y + +/-- The accumulator threads through the `addBinStep` fold independently of the remaining addend and +carry. -/ +lemma foldl_addBinStep_acc (xs ys : List Bool) (c : Bool) (acc : List Bool) : + xs.foldl addBinStep (ys, c, acc) + = ((xs.foldl addBinStep (ys, c, [])).1, (xs.foldl addBinStep (ys, c, [])).2.1, + (xs.foldl addBinStep (ys, c, [])).2.2 ++ acc) := by + induction xs generalizing ys c acc with + | nil => simp + | cons hd tl ih => + rw [List.foldl_cons, List.foldl_cons] + cases ys with + | nil => + simp only [addBinStep] + rw [ih [] _ _, ih [] _ [_]] + simp + | cons d ds => + simp only [addBinStep] + rw [ih ds _ _, ih ds _ [_]] + simp + +/-- Evaluating `addBinStep` on `y.bits` exposes the next sum bit and carry via `fullAdder`, +independently of whether `y` is zero. -/ +lemma addBinStep_bits (y : ℕ) (c b : Bool) (acc : List Bool) : + addBinStep (y.bits, c, acc) b + = (y.div2.bits, (fullAdder (Nat.bodd y) b c).2, (fullAdder (Nat.bodd y) b c).1 :: acc) := by + cases y using Nat.binaryRec' with + | zero => simp [addBinStep, Nat.zero_bits] + | bit d m hd => rw [Nat.bits_append_bit m d hd]; simp [addBinStep] + +/-- Peeling the first bit of the first addend in `addCarry`, when the second addend is `y.bits`. -/ +lemma addCarry_cons_bits (c b : Bool) (xs : List Bool) (y : ℕ) : + addCarry c (b :: xs) y.bits + = (fullAdder (Nat.bodd y) b c).1 + :: addCarry (fullAdder (Nat.bodd y) b c).2 xs y.div2.bits := by + unfold addCarry + rw [List.foldl_cons, addBinStep_bits, + foldl_addBinStep_acc xs y.div2.bits (fullAdder (Nat.bodd y) b c).2 + [(fullAdder (Nat.bodd y) b c).1]] + simp [List.reverse_append] + +lemma addCarry_correct (c : Bool) (x y : ℕ) : + addCarry c x.bits y.bits = (x + y + c.toNat).bits := by + induction x using Nat.binaryRec' generalizing c y with + | zero => cases c <;> simp [addCarry, Nat.zero_bits, succ_bin_correct] + | bit b m hb ih => + rw [Nat.bits_append_bit m b hb, addCarry_cons_bits, ih] + have hy := Nat.bodd_add_div2 y + rw [show Nat.bit b m + y + c.toNat + = Nat.bit (fullAdder (Nat.bodd y) b c).1 + (m + y.div2 + (fullAdder (Nat.bodd y) b c).2.toNat) from by + simp only [Nat.bit_val, fullAdder] + cases b <;> cases c <;> cases hbd : Nat.bodd y <;> simp_all <;> omega] + rw [Nat.bits_append_bit] + rintro hzero + have hb' : b = true := hb (by omega) + subst hb' + simp only [fullAdder] at hzero ⊢ + cases c <;> cases hbd : Nat.bodd y <;> simp_all + +lemma addBin_correct (x y : ℕ) : addBin x.bits y.bits = (x + y).bits := by + rw [addBin, addCarry_correct] + simp + +/-- The sum bit of a full adder, as a builder. -/ +def addSumPB (a bit carry : PB) : PB := boolXor (boolXor a bit) carry + +/-- The carry-out bit of a full adder, as a builder. -/ +def addCarryPB (a bit carry : PB) : PB := + boolOr (boolAnd a bit) (boolAnd carry (boolXor a bit)) + +lemma addSumPB_computes {pa pbit pc : PB} {av bv cv : Bool} + (ha : pa.ComputesEnc env av) (hbit : pbit.ComputesEnc env bv) + (hc : pc.ComputesEnc env cv) : + (addSumPB pa pbit pc).ComputesEnc env (fullAdder av bv cv).1 := by + simp only [fullAdder, addSumPB] + exact boolXor_computes (boolXor_computes ha hbit) hc + +lemma addCarryPB_computes {pa pbit pc : PB} {av bv cv : Bool} + (ha : pa.ComputesEnc env av) (hbit : pbit.ComputesEnc env bv) + (hc : pc.ComputesEnc env cv) : + (addCarryPB pa pbit pc).ComputesEnc env (fullAdder av bv cv).2 := by + simp only [fullAdder, addCarryPB] + exact boolOr_computes (boolAnd_computes ha hbit) + (boolAnd_computes hc (boolXor_computes ha hbit)) + +/-- The fold body implementing `addBinStep`. The state encodes the triple `(toAdd, carry, acc)`: +consume the front bit of `toAdd` (or `false` once it is exhausted) together with the current bit +`bit` of the first addend, emitting the sum bit onto `acc` and threading the new carry. -/ +def add_foldl_body (st bit : PB) : PB := + elim st.fst + (toPair empty + (toPair (addCarryPB (constantEnc false) bit st.snd.fst) + (cons (addSumPB (constantEnc false) bit st.snd.fst) st.snd.snd))) + (fun hd tl => + toPair tl + (toPair (addCarryPB hd bit st.snd.fst) + (cons (addSumPB hd bit st.snd.fst) st.snd.snd))) + +/-- Compute binary addition in the default ℕ encoding. Mirrors `addBin`/`addCarry`: fold +`add_foldl_body` over the first addend `x` starting from state `(y, false, [])`, then reverse the +emitted bits and append the leftover high bits (incremented when a final carry remains). -/ +def add (x y : PB) : PB := + let loop := foldl add_foldl_body (toPair y (toPair (constantEnc false) empty)) x + listAppend (reverse loop.snd.snd) (boolIte loop.snd.fst (succ loop.fst) loop.fst) + +/-- The `add` program computes `addBin` on the underlying bit lists, for any lists (not just +canonical ℕ encodings). -/ +lemma add_computes_list {px py : PB} {l1 l2 : List Bool} + (hx : px.ComputesEnc env l1) (hy : py.ComputesEnc env l2) : + (add px py).ComputesEnc env (addBin l1 l2) := by + have h_body : ∀ {e : List Value} {pa pb : PB} + {a : List Bool × Bool × List Bool} {b : Bool}, + pa.ComputesEnc e a → pb.ComputesEnc e b → + (add_foldl_body pa pb).ComputesEnc e (addBinStep a b) := by + intro e pa pb a b ha hb + obtain ⟨toAdd, carry, acc⟩ := a + cases toAdd with + | nil => + refine elim_nil_computes (fst_ComputesEnc ha) ?_ + exact toPair_computesEnc (empty_computesEnc Bool) + (toPair_computesEnc + (addCarryPB_computes constantEnc_computesEnc hb + (fst_ComputesEnc (snd_ComputesEnc ha))) + (cons_computesEnc + (addSumPB_computes constantEnc_computesEnc hb + (fst_ComputesEnc (snd_ComputesEnc ha))) + (snd_ComputesEnc (snd_ComputesEnc ha)))) + | cons hd tl => + refine elim_cons_computes (fst_ComputesEnc ha) (computesFun₂_branch2 ?_) + intro ext + have ha' := (ha.extend ext).extend + [Value.data (DataEncode.encode hd), Value.data (DataEncode.encode tl)] + have hb' := (hb.extend ext).extend + [Value.data (DataEncode.encode hd), Value.data (DataEncode.encode tl)] + exact toPair_computesEnc (var_computes_fresh2 ext []) + (toPair_computesEnc + (addCarryPB_computes (var_computes_fresh ext _) hb' + (fst_ComputesEnc (snd_ComputesEnc ha'))) + (cons_computesEnc + (addSumPB_computes (var_computes_fresh ext _) hb' + (fst_ComputesEnc (snd_ComputesEnc ha'))) + (snd_ComputesEnc (snd_ComputesEnc ha')))) + have h_fold := foldl_computes + (toPair_computesEnc hy + (toPair_computesEnc (constantEnc_computesEnc (a := false)) (empty_computesEnc Bool))) + hx h_body + unfold addBin addCarry + generalize hE : l1.foldl addBinStep (l2, false, []) = E at h_fold ⊢ + obtain ⟨tA, fC, rv⟩ := E + unfold add + exact listAppend_computes (reverse_computes (snd_ComputesEnc (snd_ComputesEnc h_fold))) + (boolIte_computes (fst_ComputesEnc (snd_ComputesEnc h_fold)) + (succ_computes_list (fst_ComputesEnc h_fold)) + (fst_ComputesEnc h_fold)) + +lemma add_computes {px py : PB} {x y : ℕ} + (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : + (add px py).ComputesEnc env (x + y) := by + change (add px py).ComputesEnc env (x + y).bits + rw [← addBin_correct] + exact add_computes_list hx hy + +/-- Doubles a binary number (the math-level `· * 2`), keeping the canonical encoding: prepend a +`false` low bit, except for `0` (the empty list) which stays empty. -/ +def doubleBin (l : List Bool) : List Bool := + match l with + | [] => [] + | _ => false :: l + +lemma doubleBin_bits (Y : ℕ) : doubleBin Y.bits = (2 * Y).bits := by + cases Y using Nat.binaryRec' with + | zero => simp [doubleBin, Nat.zero_bits] + | bit b m hb => + have hYne : Nat.bit b m ≠ 0 := Nat.bit_ne_zero_iff.mpr hb + rw [Nat.bits_append_bit m b hb, Nat.bit0_bits _ hYne, Nat.bits_append_bit m b hb] + rfl + +/-- One shift-and-add step of binary multiplication. The state `(shiftedY, product)` holds the +second addend shifted left by the current position and the running product. Each step doubles +`shiftedY` and, when the current bit of the multiplier is set, adds `shiftedY` into `product`. -/ +def mulBinStep (st : List Bool × List Bool) (bit : Bool) : List Bool × List Bool := + (doubleBin st.1, if bit then addBin st.2 st.1 else st.2) + +/-- Multiplies the bit lists `x` and `y` by folding `mulBinStep` over `x`. -/ +def mulBin (x y : List Bool) : List Bool := + (x.foldl mulBinStep (y, [])).2 + +/-- Generalised correctness of the multiplication fold: folding `mulBinStep` over `n.bits` +starting from `(Y, P)` accumulates `P + n * Y` into the product component. -/ +lemma mulBin_foldl (n Y P : ℕ) : + (n.bits.foldl mulBinStep (Y.bits, P.bits)).2 = (P + n * Y).bits := by + induction n using Nat.binaryRec' generalizing Y P with + | zero => simp [Nat.zero_bits] + | bit b m hb ih => + rw [Nat.bits_append_bit m b hb, List.foldl_cons] + have hstep : mulBinStep (Y.bits, P.bits) b + = ((2 * Y).bits, (if b then P + Y else P).bits) := by + cases b <;> simp [mulBinStep, doubleBin_bits, addBin_correct] + rw [hstep, ih] + congr 1 + have hb2 : (if b then P + Y else P) = P + b.toNat * Y := by cases b <;> simp + rw [hb2, Nat.bit_val, ← Nat.mul_assoc, Nat.mul_comm m 2, Nat.add_mul] + omega + +lemma mulBin_correct (x y : ℕ) : mulBin x.bits y.bits = (x * y).bits := by + have h := mulBin_foldl x y 0 + rw [Nat.zero_bits] at h + unfold mulBin + rw [h] + simp + +/-- The PB builder doubling a binary number, implementing `doubleBin`. -/ +def doublePB (l : PB) : PB := + elim l empty (fun hd tl => cons (constantEnc false) (cons hd tl)) + +lemma doublePB_computes {p : PB} {l : List Bool} (h : p.ComputesEnc env l) : + (doublePB p).ComputesEnc env (doubleBin l) := by + cases l with + | nil => exact elim_nil_computes h (empty_computesEnc Bool) + | cons hd tl => + refine elim_cons_computes h (computesFun₂_branch2 ?_) + intro ext + exact cons_computesEnc constantEnc_computesEnc + (cons_computesEnc (var_computes_fresh ext _) (var_computes_fresh2 ext [])) + +/-- The fold body implementing `mulBinStep`: double the shifted second addend and conditionally +add it to the running product. -/ +def mulFoldlBody (st bit : PB) : PB := + toPair (doublePB st.fst) (boolIte bit (add st.snd st.fst) st.snd) + +/-- Compute binary multiplication in the default ℕ encoding. Fold `mul_foldl_body` over the first +factor `x`, starting from state `(y, [])`; the product component of the final state is the result. +The second factor `y` is copied into the accumulator (rather than read from the environment). -/ +def mul (x y : PB) : PB := + snd (foldl mulFoldlBody (toPair y empty) x) + +lemma mul_computes {px py : PB} {x y : ℕ} + (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : + (mul px py).ComputesEnc env (x * y) := by + have h_body : ∀ {e : List Value} {pa pb : PB} + {a : List Bool × List Bool} {b : Bool}, + pa.ComputesEnc e a → pb.ComputesEnc e b → + (mulFoldlBody pa pb).ComputesEnc e (mulBinStep a b) := by + intro e pa pb a b ha hb + refine toPair_computesEnc (doublePB_computes (fst_ComputesEnc ha)) ?_ + exact boolIte_computes hb + (add_computes_list (snd_ComputesEnc ha) (fst_ComputesEnc ha)) (snd_ComputesEnc ha) + change (mul px py).ComputesEnc env (x * y).bits + rw [← mulBin_correct] + exact snd_ComputesEnc (foldl_computes + (toPair_computesEnc hy (empty_computesEnc Bool)) hx h_body) + +end PB + +end RoseTreeMachine + +end Turing diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index f407c99e2..9c819e7f2 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -342,369 +342,6 @@ lemma listHeadOption_computes {p : PB} {l : List α} (h : p.ComputesEnc env l) : apply PB.elim_cons_computes h (PB.computesFun₂_branch2 (fun ext => ?_)) refine PB.cons_computes (var_computes_fresh ext _) empty_computes -/-- The fold step used by `succBin`: given the running `(carry, acc)` and the next `bit`, emit the -new carry `carry && bit` and prepend the output bit `carry ^^ bit`. -/ -def succBinStep (p : Bool × List Bool) (bit : Bool) : Bool × List Bool := - (p.1 && bit, (p.1 ^^ bit) :: p.2) - -def succBin (n : List Bool) : List Bool := - let (final_carry, rev_res) := n.foldl succBinStep (true, []) - (if final_carry then true :: rev_res else rev_res).reverse - -/-- With carry `false`, the fold never produces a carry and simply reverses the remaining bits onto -the accumulator. -/ -lemma foldl_succBinStep_false (bs : List Bool) (acc : List Bool) : - bs.foldl succBinStep (false, acc) = (false, bs.reverse ++ acc) := by - induction bs generalizing acc with - | nil => simp - | cons hd tl ih => simp [succBinStep, ih (hd :: acc)] - -/-- The accumulator threads through the fold independently of the computed carry and output bits. -/ -lemma foldl_succBinStep_acc (bs : List Bool) (c : Bool) (acc : List Bool) : - bs.foldl succBinStep (c, acc) - = ((bs.foldl succBinStep (c, [])).1, (bs.foldl succBinStep (c, [])).2 ++ acc) := by - induction bs generalizing c acc with - | nil => simp - | cons hd tl ih => - rw [List.foldl_cons, show succBinStep (c, acc) hd = (c && hd, (c ^^ hd) :: acc) from rfl, - ih (c && hd) ((c ^^ hd) :: acc), List.foldl_cons, - show succBinStep (c, ([] : List Bool)) hd = (c && hd, [c ^^ hd]) from rfl, - ih (c && hd) [c ^^ hd]] - simp - -lemma succ_bin_correct (n : ℕ) : succBin n.bits = (n + 1).bits := by - induction n using Nat.binaryRec' with - | zero => rw [Nat.zero_bits]; rfl - | bit b m hb ih => - rw [Nat.bits_append_bit m b hb] - unfold succBin - cases b with - | false => - rw [List.foldl_cons, - show succBinStep (true, []) false = (false, [true]) from rfl, - foldl_succBinStep_false, Nat.bit_false_apply, Nat.bit1_bits] - simp - | true => - rw [List.foldl_cons, - show succBinStep (true, []) true = (true, [false]) from rfl, - foldl_succBinStep_acc, Nat.bit_true_apply, - show 2 * m + 1 + 1 = 2 * (m + 1) from by omega, - Nat.bit0_bits (m + 1) (Nat.succ_ne_zero m), ← ih] - unfold succBin - dsimp only - split <;> simp [List.reverse_append] - -def succ_foldl_body (st bit : PB) : PB := - let carry := st.fst - let acc := st.snd - toPair (boolAnd carry bit) (cons (boolXor carry bit) acc) - -/-- Compute ℕ.succ (in its default binary encoding). -/ -def succ (x : PB) : PB := - let loop_result := foldl - succ_foldl_body - (toPair (constantEnc true) empty) - x - let final_carry := loop_result.fst - let result_rev := loop_result.snd - -- If final carry, prepend 1; otherwise just reverse back - reverse (boolIte final_carry (cons (constantEnc true) result_rev) result_rev) - -/-- The `succ` program computes `succBin` on the underlying bit list, independently of whether -that list is a canonical ℕ encoding. -/ -lemma succ_computes_list {p : PB} {l : List Bool} (h : p.ComputesEnc env l) : - (succ p).ComputesEnc env (succBin l) := by - have h_body : ∀ {e : List Value} {pa pb : PB} {a : Bool × List Bool} {b : Bool}, - pa.ComputesEnc e a → pb.ComputesEnc e b → - (succ_foldl_body pa pb).ComputesEnc e - ((fun (st : Bool × List Bool) bit => (st.1 && bit, (st.1 ^^ bit) :: st.2)) a b) := by - intro e pa pb a b ha hb - exact toPair_computesEnc (boolAnd_computes (fst_ComputesEnc ha) hb) - (cons_computesEnc (boolXor_computes (fst_ComputesEnc ha) hb) (snd_ComputesEnc ha)) - have h_fold := foldl_computes - (toPair_computesEnc (constantEnc_computesEnc (a := true)) (empty_computesEnc Bool)) - h h_body - apply reverse_computes (boolIte_computes (fst_ComputesEnc h_fold) ?_ (snd_ComputesEnc h_fold)) - exact cons_computesEnc constantEnc_computesEnc (snd_ComputesEnc h_fold) - -lemma succ_computes {p : PB} {n : ℕ} (h : p.ComputesEnc env n) : - (succ p).ComputesEnc env (n + 1) := by - change (succ p).ComputesEnc env (n + 1).bits - rw [← succ_bin_correct] - exact succ_computes_list h - -/-- Computes addition of three bits, returning `(sum, carry)`. -/ -def fullAdder (x y carry : Bool) : Bool × Bool := - (x ^^ y ^^ carry, (x && y) || (carry && (x ^^ y))) - -/-- One ripple-carry step. The state `(toAdd, carry, acc)` carries the remaining bits of the second -addend (`toAdd`), the running `carry`, and the reversed output bits (`acc`). Each step consumes the -next bit of the first addend together with the front bit of `toAdd` (or `false` once `toAdd` is -exhausted), emitting the sum bit onto `acc`. -/ -def addBinStep (p : List Bool × Bool × List Bool) (bit : Bool) : List Bool × Bool × List Bool := - match p.1 with - | [] => ([], (fullAdder false bit p.2.1).2, (fullAdder false bit p.2.1).1 :: p.2.2) - | a :: as => (as, (fullAdder a bit p.2.1).2, (fullAdder a bit p.2.1).1 :: p.2.2) - -/-- Adds the bit lists `x` and `y` with an incoming `carry`. -/ -def addCarry (carry : Bool) (x y : List Bool) : List Bool := - let (toAdd, finalCarry, rev) := x.foldl addBinStep (y, carry, []) - rev.reverse ++ (if finalCarry then succBin toAdd else toAdd) - -def addBin (x y : List Bool) : List Bool := addCarry false x y - -/-- The accumulator threads through the `addBinStep` fold independently of the remaining addend and -carry. -/ -lemma foldl_addBinStep_acc (xs ys : List Bool) (c : Bool) (acc : List Bool) : - xs.foldl addBinStep (ys, c, acc) - = ((xs.foldl addBinStep (ys, c, [])).1, (xs.foldl addBinStep (ys, c, [])).2.1, - (xs.foldl addBinStep (ys, c, [])).2.2 ++ acc) := by - induction xs generalizing ys c acc with - | nil => simp - | cons hd tl ih => - rw [List.foldl_cons, List.foldl_cons] - cases ys with - | nil => - simp only [addBinStep] - rw [ih [] _ _, ih [] _ [_]] - simp - | cons d ds => - simp only [addBinStep] - rw [ih ds _ _, ih ds _ [_]] - simp - -/-- Evaluating `addBinStep` on `y.bits` exposes the next sum bit and carry via `fullAdder`, -independently of whether `y` is zero. -/ -lemma addBinStep_bits (y : ℕ) (c b : Bool) (acc : List Bool) : - addBinStep (y.bits, c, acc) b - = (y.div2.bits, (fullAdder (Nat.bodd y) b c).2, (fullAdder (Nat.bodd y) b c).1 :: acc) := by - cases y using Nat.binaryRec' with - | zero => simp [addBinStep, Nat.zero_bits] - | bit d m hd => rw [Nat.bits_append_bit m d hd]; simp [addBinStep] - -/-- Peeling the first bit of the first addend in `addCarry`, when the second addend is `y.bits`. -/ -lemma addCarry_cons_bits (c b : Bool) (xs : List Bool) (y : ℕ) : - addCarry c (b :: xs) y.bits - = (fullAdder (Nat.bodd y) b c).1 - :: addCarry (fullAdder (Nat.bodd y) b c).2 xs y.div2.bits := by - unfold addCarry - rw [List.foldl_cons, addBinStep_bits, - foldl_addBinStep_acc xs y.div2.bits (fullAdder (Nat.bodd y) b c).2 - [(fullAdder (Nat.bodd y) b c).1]] - simp [List.reverse_append] - -lemma addCarry_correct (c : Bool) (x y : ℕ) : - addCarry c x.bits y.bits = (x + y + c.toNat).bits := by - induction x using Nat.binaryRec' generalizing c y with - | zero => cases c <;> simp [addCarry, Nat.zero_bits, succ_bin_correct] - | bit b m hb ih => - rw [Nat.bits_append_bit m b hb, addCarry_cons_bits, ih] - have hy := Nat.bodd_add_div2 y - rw [show Nat.bit b m + y + c.toNat - = Nat.bit (fullAdder (Nat.bodd y) b c).1 - (m + y.div2 + (fullAdder (Nat.bodd y) b c).2.toNat) from by - simp only [Nat.bit_val, fullAdder] - cases b <;> cases c <;> cases hbd : Nat.bodd y <;> simp_all <;> omega] - rw [Nat.bits_append_bit] - rintro hzero - have hb' : b = true := hb (by omega) - subst hb' - simp only [fullAdder] at hzero ⊢ - cases c <;> cases hbd : Nat.bodd y <;> simp_all - -lemma addBin_correct (x y : ℕ) : addBin x.bits y.bits = (x + y).bits := by - rw [addBin, addCarry_correct] - simp - -/-- The sum bit of a full adder, as a builder. -/ -def addSumPB (a bit carry : PB) : PB := boolXor (boolXor a bit) carry - -/-- The carry-out bit of a full adder, as a builder. -/ -def addCarryPB (a bit carry : PB) : PB := - boolOr (boolAnd a bit) (boolAnd carry (boolXor a bit)) - -lemma addSumPB_computes {pa pbit pc : PB} {av bv cv : Bool} - (ha : pa.ComputesEnc env av) (hbit : pbit.ComputesEnc env bv) - (hc : pc.ComputesEnc env cv) : - (addSumPB pa pbit pc).ComputesEnc env (fullAdder av bv cv).1 := by - simp only [fullAdder, addSumPB] - exact boolXor_computes (boolXor_computes ha hbit) hc - -lemma addCarryPB_computes {pa pbit pc : PB} {av bv cv : Bool} - (ha : pa.ComputesEnc env av) (hbit : pbit.ComputesEnc env bv) - (hc : pc.ComputesEnc env cv) : - (addCarryPB pa pbit pc).ComputesEnc env (fullAdder av bv cv).2 := by - simp only [fullAdder, addCarryPB] - exact boolOr_computes (boolAnd_computes ha hbit) - (boolAnd_computes hc (boolXor_computes ha hbit)) - -/-- The fold body implementing `addBinStep`. The state encodes the triple `(toAdd, carry, acc)`: -consume the front bit of `toAdd` (or `false` once it is exhausted) together with the current bit -`bit` of the first addend, emitting the sum bit onto `acc` and threading the new carry. -/ -def add_foldl_body (st bit : PB) : PB := - elim st.fst - (toPair empty - (toPair (addCarryPB (constantEnc false) bit st.snd.fst) - (cons (addSumPB (constantEnc false) bit st.snd.fst) st.snd.snd))) - (fun hd tl => - toPair tl - (toPair (addCarryPB hd bit st.snd.fst) - (cons (addSumPB hd bit st.snd.fst) st.snd.snd))) - -/-- Compute binary addition in the default ℕ encoding. Mirrors `addBin`/`addCarry`: fold -`add_foldl_body` over the first addend `x` starting from state `(y, false, [])`, then reverse the -emitted bits and append the leftover high bits (incremented when a final carry remains). -/ -def add (x y : PB) : PB := - let loop := foldl add_foldl_body (toPair y (toPair (constantEnc false) empty)) x - listAppend (reverse loop.snd.snd) (boolIte loop.snd.fst (succ loop.fst) loop.fst) - -/-- The `add` program computes `addBin` on the underlying bit lists, for any lists (not just -canonical ℕ encodings). -/ -lemma add_computes_list {px py : PB} {l1 l2 : List Bool} - (hx : px.ComputesEnc env l1) (hy : py.ComputesEnc env l2) : - (add px py).ComputesEnc env (addBin l1 l2) := by - have h_body : ∀ {e : List Value} {pa pb : PB} - {a : List Bool × Bool × List Bool} {b : Bool}, - pa.ComputesEnc e a → pb.ComputesEnc e b → - (add_foldl_body pa pb).ComputesEnc e (addBinStep a b) := by - intro e pa pb a b ha hb - obtain ⟨toAdd, carry, acc⟩ := a - cases toAdd with - | nil => - refine elim_nil_computes (fst_ComputesEnc ha) ?_ - exact toPair_computesEnc (empty_computesEnc Bool) - (toPair_computesEnc - (addCarryPB_computes constantEnc_computesEnc hb - (fst_ComputesEnc (snd_ComputesEnc ha))) - (cons_computesEnc - (addSumPB_computes constantEnc_computesEnc hb - (fst_ComputesEnc (snd_ComputesEnc ha))) - (snd_ComputesEnc (snd_ComputesEnc ha)))) - | cons hd tl => - refine elim_cons_computes (fst_ComputesEnc ha) (computesFun₂_branch2 ?_) - intro ext - have ha' := (ha.extend ext).extend - [Value.data (DataEncode.encode hd), Value.data (DataEncode.encode tl)] - have hb' := (hb.extend ext).extend - [Value.data (DataEncode.encode hd), Value.data (DataEncode.encode tl)] - exact toPair_computesEnc (var_computes_fresh2 ext []) - (toPair_computesEnc - (addCarryPB_computes (var_computes_fresh ext _) hb' - (fst_ComputesEnc (snd_ComputesEnc ha'))) - (cons_computesEnc - (addSumPB_computes (var_computes_fresh ext _) hb' - (fst_ComputesEnc (snd_ComputesEnc ha'))) - (snd_ComputesEnc (snd_ComputesEnc ha')))) - have h_fold := foldl_computes - (toPair_computesEnc hy - (toPair_computesEnc (constantEnc_computesEnc (a := false)) (empty_computesEnc Bool))) - hx h_body - unfold addBin addCarry - generalize hE : l1.foldl addBinStep (l2, false, []) = E at h_fold ⊢ - obtain ⟨tA, fC, rv⟩ := E - unfold add - exact listAppend_computes (reverse_computes (snd_ComputesEnc (snd_ComputesEnc h_fold))) - (boolIte_computes (fst_ComputesEnc (snd_ComputesEnc h_fold)) - (succ_computes_list (fst_ComputesEnc h_fold)) - (fst_ComputesEnc h_fold)) - -lemma add_computes {px py : PB} {x y : ℕ} - (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : - (add px py).ComputesEnc env (x + y) := by - change (add px py).ComputesEnc env (x + y).bits - rw [← addBin_correct] - exact add_computes_list hx hy - -/-- Doubles a binary number (the math-level `· * 2`), keeping the canonical encoding: prepend a -`false` low bit, except for `0` (the empty list) which stays empty. -/ -def doubleBin (l : List Bool) : List Bool := - match l with - | [] => [] - | _ => false :: l - -lemma doubleBin_bits (Y : ℕ) : doubleBin Y.bits = (2 * Y).bits := by - cases Y using Nat.binaryRec' with - | zero => simp [doubleBin, Nat.zero_bits] - | bit b m hb => - have hYne : Nat.bit b m ≠ 0 := Nat.bit_ne_zero_iff.mpr hb - rw [Nat.bits_append_bit m b hb, Nat.bit0_bits _ hYne, Nat.bits_append_bit m b hb] - rfl - -/-- One shift-and-add step of binary multiplication. The state `(shiftedY, product)` holds the -second addend shifted left by the current position and the running product. Each step doubles -`shiftedY` and, when the current bit of the multiplier is set, adds `shiftedY` into `product`. -/ -def mulBinStep (st : List Bool × List Bool) (bit : Bool) : List Bool × List Bool := - (doubleBin st.1, if bit then addBin st.2 st.1 else st.2) - -/-- Multiplies the bit lists `x` and `y` by folding `mulBinStep` over `x`. -/ -def mulBin (x y : List Bool) : List Bool := - (x.foldl mulBinStep (y, [])).2 - -/-- Generalised correctness of the multiplication fold: folding `mulBinStep` over `n.bits` -starting from `(Y, P)` accumulates `P + n * Y` into the product component. -/ -lemma mulBin_foldl (n Y P : ℕ) : - (n.bits.foldl mulBinStep (Y.bits, P.bits)).2 = (P + n * Y).bits := by - induction n using Nat.binaryRec' generalizing Y P with - | zero => simp [Nat.zero_bits] - | bit b m hb ih => - rw [Nat.bits_append_bit m b hb, List.foldl_cons] - have hstep : mulBinStep (Y.bits, P.bits) b - = ((2 * Y).bits, (if b then P + Y else P).bits) := by - cases b <;> simp [mulBinStep, doubleBin_bits, addBin_correct] - rw [hstep, ih] - congr 1 - have hb2 : (if b then P + Y else P) = P + b.toNat * Y := by cases b <;> simp - rw [hb2, Nat.bit_val, ← Nat.mul_assoc, Nat.mul_comm m 2, Nat.add_mul] - omega - -lemma mulBin_correct (x y : ℕ) : mulBin x.bits y.bits = (x * y).bits := by - have h := mulBin_foldl x y 0 - rw [Nat.zero_bits] at h - unfold mulBin - rw [h] - simp - -/-- The PB builder doubling a binary number, implementing `doubleBin`. -/ -def doublePB (l : PB) : PB := - elim l empty (fun hd tl => cons (constantEnc false) (cons hd tl)) - -lemma doublePB_computes {p : PB} {l : List Bool} (h : p.ComputesEnc env l) : - (doublePB p).ComputesEnc env (doubleBin l) := by - cases l with - | nil => exact elim_nil_computes h (empty_computesEnc Bool) - | cons hd tl => - refine elim_cons_computes h (computesFun₂_branch2 ?_) - intro ext - exact cons_computesEnc constantEnc_computesEnc - (cons_computesEnc (var_computes_fresh ext _) (var_computes_fresh2 ext [])) - -/-- The fold body implementing `mulBinStep`: double the shifted second addend and conditionally -add it to the running product. -/ -def mulFoldlBody (st bit : PB) : PB := - toPair (doublePB st.fst) (boolIte bit (add st.snd st.fst) st.snd) - -/-- Compute binary multiplication in the default ℕ encoding. Fold `mul_foldl_body` over the first -factor `x`, starting from state `(y, [])`; the product component of the final state is the result. -The second factor `y` is copied into the accumulator (rather than read from the environment). -/ -def mul (x y : PB) : PB := - snd (foldl mulFoldlBody (toPair y empty) x) - -lemma mul_computes {px py : PB} {x y : ℕ} - (hx : px.ComputesEnc env x) (hy : py.ComputesEnc env y) : - (mul px py).ComputesEnc env (x * y) := by - have h_body : ∀ {e : List Value} {pa pb : PB} - {a : List Bool × List Bool} {b : Bool}, - pa.ComputesEnc e a → pb.ComputesEnc e b → - (mulFoldlBody pa pb).ComputesEnc e (mulBinStep a b) := by - intro e pa pb a b ha hb - refine toPair_computesEnc (doublePB_computes (fst_ComputesEnc ha)) ?_ - exact boolIte_computes hb - (add_computes_list (snd_ComputesEnc ha) (fst_ComputesEnc ha)) (snd_ComputesEnc ha) - change (mul px py).ComputesEnc env (x * y).bits - rw [← mulBin_correct] - exact snd_ComputesEnc (foldl_computes - (toPair_computesEnc hy (empty_computesEnc Bool)) hx h_body) - -- Evaluate a function `f` at `arg` where the function is given as a graph (list of pairs). -- Returns `some y` for the first `x` in the graph such that `f x = y` and `none` otherwise. def evalFunGraph (graph : PB) (arg : PB) : PB := From 2767b448307a220d31e10d8a51801a571f4df01c Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 16 Jun 2026 18:33:46 +0200 Subject: [PATCH 13/22] for loops --- Cslib/Computability/Machines/RTM/Arith.lean | 95 +++++++++++++++++++++ Cslib/Computability/Machines/RTM/PB.lean | 14 +++ 2 files changed, 109 insertions(+) diff --git a/Cslib/Computability/Machines/RTM/Arith.lean b/Cslib/Computability/Machines/RTM/Arith.lean index a714ef409..f709a3f90 100644 --- a/Cslib/Computability/Machines/RTM/Arith.lean +++ b/Cslib/Computability/Machines/RTM/Arith.lean @@ -20,6 +20,7 @@ program builder. - `PB.succ` - the successor `n + 1` - `PB.add` - binary addition `x + y` - `PB.mul` - binary multiplication `x * y` +- `PB.forLoop` - a bounded `for` loop running a body `f i acc` for `i = 0, …, n - 1` -/ @@ -398,6 +399,100 @@ lemma mul_computes {px py : PB} {x y : ℕ} exact snd_ComputesEnc (foldl_computes (toPair_computesEnc hy (empty_computesEnc Bool)) hx h_body) +/-! ### Bounded `for` loops + +`forLoop n init f` runs `acc := f i acc` for `i = 0, 1, …, n - 1` and returns the final +accumulator, where `n` is given in binary. It is a `while_` loop counting an index `i` up from `0` +to `n`. The loop state is the quadruple `(continue?, i, n, acc)`: the counter `i`, the bound `n` and +the user accumulator `acc` are all threaded through the state (so the body never reaches into the +surrounding environment), and the loop terminates once `i = n`, detected by comparing `i` and `n` +for equality. Crucially the loop does **not** materialise the list of indices, so its state stays +proportional to `n`'s binary size rather than to `n`. -/ + +/-- One iteration of the `forLoop` loop. The state is the quadruple `(continue?, i, n, acc)` +(encoded as nested pairs): update the accumulator to `f i acc`, increment `i`, and recompute the +guard `i + 1 ≠ n`. The bound `n` is threaded through unchanged. -/ +def forLoopBody (pf : PB → PB → PB) (st : PB) : PB := + toPair (boolNot (isEq (succ st.snd.fst) st.snd.snd.fst)) + (toPair (succ st.snd.fst) + (toPair st.snd.snd.fst (pf st.snd.fst st.snd.snd.snd))) + +private lemma forLoopBody_step {pf : PB → PB → PB} {f : ℕ → α → α} + (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, + pi.ComputesEnc e i → pacc.ComputesEnc e a → (pf pi pacc).ComputesEnc e (f i a)) + (i n : ℕ) (acc : α) : + computesFun₁ env + (.data (DataEncode.encode ((!(i == n), i, n, acc) : Bool × ℕ × ℕ × α))) + (forLoopBody pf) + (.data (DataEncode.encode + ((!(i + 1 == n), i + 1, n, f i acc) : Bool × ℕ × ℕ × α))) := by + apply computesFun₁_branch + intro ext + have hst : (PB.var (env.length + ext.length)).ComputesEnc + (env ++ ext ++ [Value.data (DataEncode.encode + ((!(i == n), i, n, acc) : Bool × ℕ × ℕ × α))]) + ((!(i == n), i, n, acc) : Bool × ℕ × ℕ × α) := var_computes_fresh ext [] + have hpi := fst_ComputesEnc (snd_ComputesEnc hst) + have hpn := fst_ComputesEnc (snd_ComputesEnc (snd_ComputesEnc hst)) + have hpacc := snd_ComputesEnc (snd_ComputesEnc (snd_ComputesEnc hst)) + simp only [forLoopBody] + exact toPair_computesEnc (boolNot_computes (isEq_computes (succ_computes hpi) hpn)) + (toPair_computesEnc (succ_computes hpi) + (toPair_computesEnc hpn (hf hpi hpacc))) + +private lemma forLoop_loop {pf : PB → PB → PB} {f : ℕ → α → α} + (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, + pi.ComputesEnc e i → pacc.ComputesEnc e a → (pf pi pacc).ComputesEnc e (f i a)) + (n : ℕ) (init : α) : ∀ (k i : ℕ) (acc : α), + i + k = n → acc = (List.range i).foldl (fun a j => f j a) init → + WhileComputes env (forLoopBody pf) + (DataEncode.encode ((!(i == n), i, n, acc) : Bool × ℕ × ℕ × α)) + (DataEncode.encode ((!(n == n), n, n, + (List.range n).foldl (fun a j => f j a) init) : Bool × ℕ × ℕ × α)) := by + intro k + induction k with + | zero => + intro i acc hik hacc + obtain rfl : i = n := by omega + subst hacc + apply WhileComputes.halt + simp [DataEncode.encode] + | succ k ih => + intro i acc hik hacc + have hne : i ≠ n := by omega + refine WhileComputes.step ?_ (forLoopBody_step hf i n acc) ?_ + · simp [DataEncode.encode, show (i == n) = false from by simpa using hne] + · refine ih (i + 1) (f i acc) (by omega) ?_ + simp only [List.range_succ, List.foldl_append, List.foldl_cons, List.foldl_nil, ← hacc] + +/-- Bounded `for` loop: given the bound `n` in binary, an initial accumulator `init`, and a body +`f i acc`, runs `acc := f i acc` for `i = 0, 1, …, n - 1` and returns the final accumulator. +Implemented directly as a `while_` loop on the state `(continue?, i, n, acc)`, comparing the +counter `i` with `n` for termination; it never builds the list of indices. -/ +def forLoop (pn pinit : PB) (pf : PB → PB → PB) : PB := + snd (snd (snd (PB.while_ + (toPair (boolNot (isEq (constantEnc (0 : ℕ)) pn)) + (toPair (constantEnc (0 : ℕ)) (toPair pn pinit))) + (forLoopBody pf)))) + +lemma forLoop_computes {pn pinit : PB} {pf : PB → PB → PB} + {n : ℕ} {init : α} {f : ℕ → α → α} + (hn : pn.ComputesEnc env n) (hinit : pinit.ComputesEnc env init) + (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, + pi.ComputesEnc e i → pacc.ComputesEnc e a → (pf pi pacc).ComputesEnc e (f i a)) : + (forLoop pn pinit pf).ComputesEnc env + ((List.range n).foldl (fun acc i => f i acc) init) := by + have h_init : (toPair (boolNot (isEq (constantEnc (0 : ℕ)) pn)) + (toPair (constantEnc (0 : ℕ)) (toPair pn pinit))).ComputesEnc env + ((!(0 == n), 0, n, init) : Bool × ℕ × ℕ × α) := + toPair_computesEnc (boolNot_computes (isEq_computes constantEnc_computesEnc hn)) + (toPair_computesEnc constantEnc_computesEnc (toPair_computesEnc hn hinit)) + have hwhile : (PB.while_ _ (forLoopBody pf)).ComputesEnc env + ((!(n == n), n, n, (List.range n).foldl (fun a j => f j a) init) + : Bool × ℕ × ℕ × α) := + while_computes h_init (forLoop_loop hf n init n 0 init (by omega) (by simp)) + exact snd_ComputesEnc (snd_ComputesEnc (snd_ComputesEnc hwhile)) + end PB end RoseTreeMachine diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index 37e3f12fa..d650305b1 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -414,6 +414,20 @@ def UsesLinearTimeAndSpace (impl : PB) : Prop := PB.UsesOTime impl (fun env => (env.map fun x => x.size).sum) ∧ PB.UsesOSpace impl (fun env => (env.map fun x => x.size).sum) +def ComputesFunInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] + (p : PB → PB) (φ : α → β) (t s : α → ℕ) : Prop := + ∀ (env : List Value) (a : PB) (x : α) (ta sa : ℕ), + (∀ ext : List Value, ProgSem (env ++ ext) (a (env.length + ext.length)) + (.data (DataEncode.encode x)) ta sa) → + (∀ ext : List Value, ∃ t' ≤ t x, ∃ s' ≤ s x, ProgSem (env ++ ext) (p a (env.length + ext.length)) + (.data (DataEncode.encode (φ x))) (t' + ta) (max s' sa)) + +def ComputesFunInLinearTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] + (p : PB → PB) (φ : α → β) : Prop := + ∃ k, ComputesFunInTimeAndSpace p φ + (fun x => k * (DataEncode.encode x).size + k) + (fun x => k * (DataEncode.encode x).size + k) + end PB end RoseTreeMachine From 01a92319186bfeddd62e828539f7ba6afb200649 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 17 Jun 2026 18:12:52 +0200 Subject: [PATCH 14/22] Step-bounded simulator. --- Cslib/Computability/Machines/RTM/Arith.lean | 14 +- Cslib/Computability/Machines/RTM/PB.lean | 10 + .../Machines/RTM/TMSimulator.lean | 221 +++++++++++++++++- Cslib/Computability/Machines/RTM/Tools.lean | 73 ++++-- 4 files changed, 286 insertions(+), 32 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Arith.lean b/Cslib/Computability/Machines/RTM/Arith.lean index f709a3f90..2e5ae9570 100644 --- a/Cslib/Computability/Machines/RTM/Arith.lean +++ b/Cslib/Computability/Machines/RTM/Arith.lean @@ -418,7 +418,7 @@ def forLoopBody (pf : PB → PB → PB) (st : PB) : PB := (toPair st.snd.snd.fst (pf st.snd.fst st.snd.snd.snd))) private lemma forLoopBody_step {pf : PB → PB → PB} {f : ℕ → α → α} - (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, + (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, env <+: e → pi.ComputesEnc e i → pacc.ComputesEnc e a → (pf pi pacc).ComputesEnc e (f i a)) (i n : ℕ) (acc : α) : computesFun₁ env @@ -435,13 +435,16 @@ private lemma forLoopBody_step {pf : PB → PB → PB} {f : ℕ → α → α} have hpi := fst_ComputesEnc (snd_ComputesEnc hst) have hpn := fst_ComputesEnc (snd_ComputesEnc (snd_ComputesEnc hst)) have hpacc := snd_ComputesEnc (snd_ComputesEnc (snd_ComputesEnc hst)) + have hpre : env <+: env ++ ext ++ [Value.data (DataEncode.encode + ((!(i == n), i, n, acc) : Bool × ℕ × ℕ × α))] := + (List.prefix_append env ext).trans (List.prefix_append _ _) simp only [forLoopBody] exact toPair_computesEnc (boolNot_computes (isEq_computes (succ_computes hpi) hpn)) (toPair_computesEnc (succ_computes hpi) - (toPair_computesEnc hpn (hf hpi hpacc))) + (toPair_computesEnc hpn (hf hpre hpi hpacc))) private lemma forLoop_loop {pf : PB → PB → PB} {f : ℕ → α → α} - (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, + (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, env <+: e → pi.ComputesEnc e i → pacc.ComputesEnc e a → (pf pi pacc).ComputesEnc e (f i a)) (n : ℕ) (init : α) : ∀ (k i : ℕ) (acc : α), i + k = n → acc = (List.range i).foldl (fun a j => f j a) init → @@ -477,8 +480,9 @@ def forLoop (pn pinit : PB) (pf : PB → PB → PB) : PB := lemma forLoop_computes {pn pinit : PB} {pf : PB → PB → PB} {n : ℕ} {init : α} {f : ℕ → α → α} - (hn : pn.ComputesEnc env n) (hinit : pinit.ComputesEnc env init) - (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, + (hn : pn.ComputesEnc env n) + (hinit : pinit.ComputesEnc env init) + (hf : ∀ {e : List Value} {pi pacc : PB} {i : ℕ} {a : α}, env <+: e → pi.ComputesEnc e i → pacc.ComputesEnc e a → (pf pi pacc).ComputesEnc e (f i a)) : (forLoop pn pinit pf).ComputesEnc env ((List.range n).foldl (fun acc i => f i acc) init) := by diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index d650305b1..2ec8a1635 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -300,6 +300,16 @@ lemma ifeq_ne_computes {x y then_ else_ : PB} {vx vy : Data} {out : Value} simp only [PB.ifEq] exact ⟨_, _, ProgSem.ifEq_else hx' hy' hne helse'⟩ +lemma ifeq_computes {x y then_ else_ : PB} {vx vy : Data} {out₁ out₂ : Value} + (hx : Computes env x (.data vx)) + (hy : Computes env y (.data vy)) + (hthen : Computes env then_ out₁) + (helse : Computes env else_ out₂) : + Computes env (PB.ifEq x y then_ else_) (if vx == vy then out₁ else out₂) := by + by_cases h : vx = vy + · exact ifeq_eq_computes hx (h ▸ hy) (by simpa [h] using hthen) + · exact ifeq_ne_computes hx hy h (by simpa [h] using helse) + /-- In-place application of a literal abstraction (a `let` binding): if `arg` computes `dx` and `body` computes `out` with its parameter bound to `dx`, then `app (fn body) arg` computes `out`. -/ diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 89bf7d04e..2c2847ddc 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -7,6 +7,7 @@ Authors: Christian Reitwiessner module public import Cslib.Computability.Machines.RTM.Tools +public import Cslib.Computability.Machines.RTM.Arith public import Cslib.Computability.Machines.SingleTapeTuring.Basic public import Mathlib.Data.List.ReduceOption @@ -197,9 +198,7 @@ lemma bitapeMove_computes {p_t p_dir : PB} {t : BiTape Symbol} {d : Dir} /-- Models `BiTape.optionMove` -/ def bitapeOptionMove (t dir : PB) : PB := - PB.optionElim dir - t - (fun d => bitapeMove t d) + dir.optionElim t (fun d => bitapeMove t d) lemma bitapeOptionMove_computes {p_t p_dir : PB} {t : BiTape Symbol} {d : Option Dir} @@ -326,6 +325,43 @@ lemma singleTapeTMStep_computes refine evalTr_computes (h_tr.extend ext |>.extend _) (PB.var_computes_fresh ext _) ?_ exact PB.head_computes (cfgBitape_computes (h_cfg.extend ext |>.extend _)) +/-- Run the step function for `steps` iterations, staying at a halting configuration. -/ +def timeBoundedSimulatorMain (tr cfg steps : PB) : PB := + PB.forLoop steps cfg (fun _ cfg => (singleTapeTMStep tr cfg).optionElim cfg (fun next => next)) + +lemma timeBoundedSimulator_computes + [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} + [DataEncode tm.State] + {p_tr p_cfg p_steps : PB} + {cfg : tm.Cfg} + {steps : ℕ} + (h_tr : p_tr.ComputesEnc env + ((Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c')))))) + (h_cfg : p_cfg.ComputesEnc env cfg) + (h_steps : p_steps.ComputesEnc env steps) : + (timeBoundedSimulatorMain p_tr p_cfg p_steps).ComputesEnc env + ((fun c => (tm.step c).getD c)^[steps] cfg) := by + have : ∀ g m (b : tm.Cfg), g^[m] b = (List.range m).foldl (fun c _ => g c) b := by + intro g m + induction m with + | zero => simp + | succ m ih => + intro b + simp [Function.iterate_succ_apply', ih, List.range_succ] + rw [this] + apply PB.forLoop_computes (f := fun _ c => (tm.step c).getD c) h_steps h_cfg + intro e pi pacc i c hpre h_pi h_acc + obtain ⟨more, rfl⟩ := hpre + have hstep := singleTapeTMStep_computes (h_tr.extend more) h_acc + cases hsc : tm.step c with + | none => exact PB.optionElim_computesEnc_none (hsc ▸ hstep) h_acc + | some next => + exact PB.optionElim_computesEnc_some (hsc ▸ hstep) + (PB.computesFun₂_branch (fun ext => PB.var_computes_fresh ext _)) + /-- The main loop of the Turing machine simulation: Execute a step until we reach a halting configuration, then return it. -/ def tmMainLoop (tr : PB) (cfg : PB) : PB := @@ -333,7 +369,7 @@ def tmMainLoop (tr : PB) (cfg : PB) : PB := -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep -- the current `acc` (which has `state = none`, signalling halt to `while_`). PB.while_ cfg - (fun acc => PB.optionElim (singleTapeTMStep tr acc) acc (fun next => next)) + (fun acc => (singleTapeTMStep tr acc).optionElim acc (fun next => next)) lemma tmMainLoop_computes [Inhabited Symbol] [Fintype Symbol] @@ -436,6 +472,183 @@ with an empty left part — which is exactly the shape of the `haltCfg`s produce def finalConfigToOutput (cfg : PB) : PB := (PB.cons (bitapeHead (cfgBitape cfg)) (bitapeRight (cfgBitape cfg))).listReduceOption +def tapeCellsToOutputF (l : List (Option Symbol)) : Option (List Symbol) := + l.foldl + (fun res s => + match res with + | none => none + | some res => match s with + | none => none + | some s => some (res ++ [s])) + (some []) + +def tapeCellsToOutput (l : PB) : PB := + PB.foldl (fun res s => + res.optionElim + .none + (fun res => s.optionElim .none (fun s => .some (.listAppend res (.some s))))) + (PB.some .empty) + l + +lemma tapeCellsToOutput_computes + {p_l : PB} + {l : List (Option Symbol)} + (h_l : p_l.ComputesEnc env l) : + (tapeCellsToOutput p_l).ComputesEnc env (tapeCellsToOutputF l) := by + apply PB.foldl_computes (PB.some_ComputesEnc (PB.empty_computesEnc _)) h_l + intro e p_res p_s res s h_res h_s + cases res with + | none => exact PB.optionElim_computesEnc_none h_res PB.none_computes + | some res => + refine PB.optionElim_computesEnc_some h_res (PB.computesFun₂_branch (fun ext => ?_)) + cases s with + | none => + exact PB.optionElim_computesEnc_none ((h_s.extend ext).extend _) PB.none_computes + | some s => + refine PB.optionElim_computesEnc_some ((h_s.extend ext).extend _) + (PB.computesFun₂_branch (fun ext2 => ?_)) + exact PB.some_ComputesEnc (PB.listAppend_computes + (((PB.var_computes_fresh ext _).extend ext2).extend _) + (PB.cons_computesEnc (PB.var_computes_fresh ext2 _) (PB.empty_computesEnc _))) + + +def tapeToOutputF [DecidableEq Symbol] + (tape : BiTape Symbol) : Option (List Symbol) := + if !tape.left.toList.isEmpty then + none + else if tape.right.toList.isEmpty && tape.head.isNone then + some [] + else + tapeCellsToOutputF (tape.head :: tape.right.toList) + +def tapeToOutput (tape : PB) : PB := + PB.boolIte (.boolNot (bitapeLeft tape).listIsEmpty) + .none + (.boolIte (.boolAnd (bitapeRight tape).listIsEmpty (bitapeHead tape).isNone) + (PB.some .empty) + (tapeCellsToOutput (PB.cons (bitapeHead tape) (bitapeRight tape)))) + +lemma tapeToOutput_computes [DecidableEq Symbol] + {p_tape : PB} + {tape : BiTape Symbol} + (h_tape : p_tape.ComputesEnc env tape) : + (tapeToOutput p_tape).ComputesEnc env (tapeToOutputF tape) := by + refine PB.boolIte_computes + (PB.boolNot_computes (PB.listIsEmpty_computes (bitapeLeft_computes h_tape))) + (PB.empty_computes) ?_ + refine PB.boolIte_computes (α := Option (List Symbol)) ?_ ?_ ?_ + · refine PB.boolAnd_computes + (PB.listIsEmpty_computes (bitapeRight_computes h_tape)) + (PB.isNone_computes (bitapeHead_computes h_tape)) + · exact PB.some_ComputesEnc (PB.empty_computesEnc (Option (List Symbol))) + · exact tapeCellsToOutput_computes + (PB.cons_computesEnc (bitapeHead_computes h_tape) (bitapeRight_computes h_tape)) + +omit [DataEncode Symbol] in +/-- `tapeCellsToOutputF` succeeds exactly when every cell is filled, returning the unwrapped +list. -/ +lemma tapeCellsToOutputF_eq_some_iff (os : List (Option Symbol)) (r : List Symbol) : + tapeCellsToOutputF os = some r ↔ os = r.map some := by + rw [tapeCellsToOutputF] + set F : Option (List Symbol) → Option Symbol → Option (List Symbol) := + fun res s => match res with + | none => none + | some res => match s with + | none => none + | some s => some (res ++ [s]) with hF + have foldNone : ∀ os, List.foldl F none os = none := by + intro os + induction os with + | nil => rfl + | cons o os ih => rw [List.foldl_cons, show F none o = none from by rw [hF]]; exact ih + have key : ∀ (os : List (Option Symbol)) (acc r : List Symbol), + List.foldl F (some acc) os = some r ↔ ∃ l, os = l.map some ∧ r = acc ++ l := by + intro os + induction os with + | nil => + intro acc r + simp only [List.foldl_nil, Option.some.injEq] + constructor + · exact fun h => ⟨[], by simp, by simp [h]⟩ + · rintro ⟨l, hl, hr⟩ + obtain rfl : l = [] := by simpa using hl.symm + simpa using hr.symm + | cons o os ih => + intro acc r + cases o with + | none => + rw [List.foldl_cons, show F (some acc) none = none from by rw [hF], foldNone] + constructor + · exact fun h => absurd h (by simp) + · rintro ⟨l, hl, -⟩; cases l <;> simp at hl + | some x => + rw [List.foldl_cons, show F (some acc) (some x) = some (acc ++ [x]) from by rw [hF], ih] + constructor + · rintro ⟨l, hl, hr⟩; exact ⟨x :: l, by simp [hl], by simp [hr]⟩ + · rintro ⟨l, hl, hr⟩ + cases l with + | nil => simp at hl + | cons y l => + simp only [List.map_cons, List.cons.injEq, Option.some.injEq] at hl + obtain ⟨rfl, rfl⟩ := hl + exact ⟨l, rfl, by simp [hr]⟩ + rw [key] + simp only [List.nil_append] + exact ⟨fun ⟨_, hos, hr⟩ => hr ▸ hos, fun hos => ⟨r, hos, rfl⟩⟩ + +omit [DataEncode Symbol] in +lemma tapeToOutput_iff_mk₁ [Inhabited Symbol] [DecidableEq Symbol] + (tape : BiTape Symbol) (s : List Symbol) : + (tape = .mk₁ s) ↔ tapeToOutputF tape = some s := by + obtain ⟨hd, lft, rgt⟩ := tape + simp only [tapeToOutputF] + by_cases hl : lft.toList = [] + · rw [if_neg (by simp [hl])] + obtain rfl : lft = ∅ := by cases lft; simp_all [StackTape.nil] + by_cases hr : (rgt.toList.isEmpty && hd.isNone) = true + · rw [if_pos hr] + simp only [Bool.and_eq_true, List.isEmpty_iff, Option.isNone_iff_eq_none] at hr + obtain ⟨hr1, hr2⟩ := hr + subst hr2 + obtain rfl : rgt = ∅ := by cases rgt; simp_all [StackTape.nil] + rw [Option.some.injEq] + constructor + · intro h; cases s with + | nil => rfl + | cons a t => simp [BiTape.mk₁, BiTape.mk.injEq] at h + · rintro rfl; simp [BiTape.mk₁, BiTape.nil] + · rw [if_neg hr, tapeCellsToOutputF_eq_some_iff] + cases s with + | nil => + simp only [BiTape.mk₁, List.map_nil] + constructor + · intro h + simp only [BiTape.empty_eq_nil, BiTape.nil, BiTape.mk.injEq] at h + obtain ⟨hhd, -, hrgt⟩ := h + subst hhd; subst hrgt + exact absurd (by simp [StackTape.nil]) hr + · exact fun h => absurd h (by simp) + | cons a t => + simp only [BiTape.mk₁, List.map_cons] + constructor + · intro h + rw [BiTape.mk.injEq] at h + obtain ⟨hhd, -, hrgt⟩ := h + rw [hhd, hrgt]; simp [StackTape.mapSome] + · intro h + rw [List.cons.injEq] at h + obtain ⟨hhd, hrgt⟩ := h + rw [BiTape.mk.injEq] + refine ⟨hhd, rfl, ?_⟩ + cases rgt with | mk R hR => simp_all [StackTape.mapSome] + · rw [if_pos (by simp [hl])] + simp only [reduceCtorEq, iff_false] + intro hcontra + apply hl + have : lft = (BiTape.mk₁ s).left := by rw [← hcontra] + rw [this] + cases s <;> simp [BiTape.mk₁, BiTape.nil, StackTape.nil] + lemma finalConfigToOutput_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {p_cfg : PB} {cfg : tm.Cfg} diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index 9c819e7f2..f49f54499 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -44,6 +44,26 @@ variable {env : List Value} variable {α : Type} [DataEncode α] variable {β : Type} [DataEncode β] +/-- Program that evaluates to the constant `a`. -/ +def constant (a : Data) : PB := match a with + | Data.l [] => .empty + | Data.l (x :: xs) => .cons (constant x) (constant (Data.l xs)) + +@[simp] +lemma constant_computes {a : Data} : (constant a).Computes env (.data a) := by + induction a using Data.inductionL with + | nil => simp [constant] + | cons hd tl ih_hd ih_tl => + simpa [constant] using cons_computes ih_hd ih_tl + +def constantEnc {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a) + +@[simp] +lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : + (constantEnc a).ComputesEnc env a := by + simp [ComputesEnc, constantEnc] + + /-- Returns the tail of a list-valued builder (`[]` when empty). -/ def tail (x : PB) : PB := .elim x .empty (fun _hd tl => tl) @@ -90,6 +110,11 @@ lemma snd_ComputesEnc {x : PB} {a : α × β} (hx : x.ComputesEnc env a) : obtain ⟨a, b⟩ := a apply PB.head_computes (PB.tail_computes hx) +def none : PB := .empty + +lemma none_computes : none.ComputesEnc env (Option.none : Option α) := by + apply empty_computes + /-- `Option.some` as a singleton list. -/ def some (x : PB) : PB := cons x empty @@ -103,7 +128,7 @@ def optionElim (x noneCase : PB) (someCase : PB → PB) : PB := lemma optionElim_computesEnc_none {x noneCase : PB} {someCase : PB → PB} - (hx : x.ComputesEnc env (none : Option α)) + (hx : x.ComputesEnc env (Option.none : Option α)) {a : β} (h_none : noneCase.ComputesEnc env a) : (optionElim x noneCase someCase).ComputesEnc env a := by @@ -120,6 +145,15 @@ lemma optionElim_computesEnc_some apply PB.elim_cons_computes (head := DataEncode.encode a) (tail := []) (by simpa [ComputesEnc, DataEncode.encode] using hx) h_some +def isNone (x : PB) : PB := x.optionElim (constantEnc true) (fun _ => constantEnc false) + +lemma isNone_computes {p : PB} {a : Option α} (h : p.ComputesEnc env a) : + (PB.isNone p).ComputesEnc env a.isNone := by + match h_a : a with + | .none => refine optionElim_computesEnc_none h (constantEnc_computesEnc (α := Bool)) + | .some a => + refine optionElim_computesEnc_some h (computesFun₂_branch (fun ext => constantEnc_computesEnc)) + /-- Build the two-element list `[a, b]` (used as an encoded pair). -/ def toPair (a b : PB) : PB := cons a (PB.cons b empty) @@ -129,26 +163,6 @@ lemma toPair_computesEnc (toPair pa pb).ComputesEnc env (a, b) := by apply PB.cons_computes ha (PB.cons_computes hb empty_computes) -/-- Program that evaluates to the constant `a`. -/ -def constant (a : Data) : PB := match a with - | Data.l [] => .empty - | Data.l (x :: xs) => .cons (constant x) (constant (Data.l xs)) - -@[simp] -lemma constant_computes {a : Data} : (constant a).Computes env (.data a) := by - induction a using Data.inductionL with - | nil => simp [constant] - | cons hd tl ih_hd ih_tl => - simpa [constant] using cons_computes ih_hd ih_tl - -def constantEnc {α : Type} [DataEncode α] (a : α) : PB := constant (DataEncode.encode a) - -@[simp] -lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : - (constantEnc a).ComputesEnc env a := by - simp [ComputesEnc, constantEnc] - - def isEq (x y : PB) : PB := ifEq x y (constantEnc true) (constantEnc false) @@ -272,6 +286,19 @@ lemma reverse_computes {p : PB} {l : List α} (h : p.ComputesEnc env l) : intro env p_tl p_hd tl hd h_tl h_hd exact cons_computesEnc h_hd h_tl +def listIsEmpty (l : PB) : PB := + isEq l empty + +lemma listIsEmpty_computes {p_l : PB} {l : List α} (h : p_l.ComputesEnc env l) : + (listIsEmpty p_l).ComputesEnc env l.isEmpty := by + by_cases h_empty : l = [] + · rw [h_empty] at h ⊢ + refine PB.ifeq_eq_computes h empty_computes PB.constantEnc_computesEnc + · rw [show l.isEmpty = false from by simp [h_empty]] + apply PB.ifeq_ne_computes h empty_computes + (fun heq => h_empty (DataEncode.h_inj heq)) + PB.constantEnc_computesEnc + def listAppend (x y : PB) : PB := foldl (fun acc el => cons el acc) y (reverse x) @@ -419,7 +446,7 @@ lemma evalFunGraph_computes -- The loop iterates the body from `(g, none)` to `([], find-result)` for any remaining list `g`. have h_loop : ∀ g : List (α × β), WhileComputes env (evalFunGraphInner p_arg) - (DataEncode.encode (g, (none : Option β))) + (DataEncode.encode (g, (Option.none : Option β))) (DataEncode.encode (([] : List (α × β)), (g.find? (fun p => p.1 = a)).map (·.2))) := by intro g @@ -453,7 +480,7 @@ lemma evalFunGraph_computes rw [if_neg (show ¬ ((x == a) = true) by simpa using h)] at hb exact WhileComputes.step (by simp [DataEncode.encode]) hb ih -- Initial accumulator: `(graph, none)`. - have h_init : (toPair p_graph .empty).ComputesEnc env (graph, (none : Option β)) := + have h_init : (toPair p_graph .empty).ComputesEnc env (graph, (.none : Option β)) := toPair_computesEnc h_graph (empty_computes) exact snd_ComputesEnc (while_computes h_init (h_loop graph)) From 562b0e23aed9f411a840d3b48d994dc73e3db438 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 17 Jun 2026 18:13:59 +0200 Subject: [PATCH 15/22] lint --- Cslib/Computability/Machines/RTM/PB.lean | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index 2ec8a1635..83d90cf1f 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -427,9 +427,9 @@ def UsesLinearTimeAndSpace (impl : PB) : Prop := def ComputesFunInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] (p : PB → PB) (φ : α → β) (t s : α → ℕ) : Prop := ∀ (env : List Value) (a : PB) (x : α) (ta sa : ℕ), - (∀ ext : List Value, ProgSem (env ++ ext) (a (env.length + ext.length)) + (∀ ext, ProgSem (env ++ ext) (a (env.length + ext.length)) (.data (DataEncode.encode x)) ta sa) → - (∀ ext : List Value, ∃ t' ≤ t x, ∃ s' ≤ s x, ProgSem (env ++ ext) (p a (env.length + ext.length)) + (∀ ext, ∃ t' ≤ t x, ∃ s' ≤ s x, ProgSem (env ++ ext) (p a (env.length + ext.length)) (.data (DataEncode.encode (φ x))) (t' + ta) (max s' sa)) def ComputesFunInLinearTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] From 4eb553a0681f2c55f806916d124e40f9e8825e50 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 18 Jun 2026 11:02:56 +0200 Subject: [PATCH 16/22] Simulator in progress. --- Cslib/Computability/Machines/RTM/PB.lean | 12 +- .../Machines/RTM/TMSimulator.lean | 267 ++++++++++++------ 2 files changed, 186 insertions(+), 93 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index 83d90cf1f..e31f04b53 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -424,13 +424,17 @@ def UsesLinearTimeAndSpace (impl : PB) : Prop := PB.UsesOTime impl (fun env => (env.map fun x => x.size).sum) ∧ PB.UsesOSpace impl (fun env => (env.map fun x => x.size).sum) -def ComputesFunInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] - (p : PB → PB) (φ : α → β) (t s : α → ℕ) : Prop := - ∀ (env : List Value) (a : PB) (x : α) (ta sa : ℕ), +def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] + (p : PB → PB) (x : α) (y : β) (t s : α → ℕ) : Prop := + ∀ (env : List Value) (a : PB) (ta sa : ℕ), (∀ ext, ProgSem (env ++ ext) (a (env.length + ext.length)) (.data (DataEncode.encode x)) ta sa) → (∀ ext, ∃ t' ≤ t x, ∃ s' ≤ s x, ProgSem (env ++ ext) (p a (env.length + ext.length)) - (.data (DataEncode.encode (φ x))) (t' + ta) (max s' sa)) + (.data (DataEncode.encode y)) (t' + ta) (max s' sa)) + +def ComputesFunInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] + (p : PB → PB) (φ : α → β) (t s : α → ℕ) : Prop := + ∀ x, ComputesInTimeAndSpace p x (φ x) t s def ComputesFunInLinearTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] (p : PB → PB) (φ : α → β) : Prop := diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 2c2847ddc..131c9474e 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -329,7 +329,7 @@ lemma singleTapeTMStep_computes def timeBoundedSimulatorMain (tr cfg steps : PB) : PB := PB.forLoop steps cfg (fun _ cfg => (singleTapeTMStep tr cfg).optionElim cfg (fun next => next)) -lemma timeBoundedSimulator_computes +lemma timeBoundedSimulatorMain_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] @@ -362,77 +362,6 @@ lemma timeBoundedSimulator_computes exact PB.optionElim_computesEnc_some (hsc ▸ hstep) (PB.computesFun₂_branch (fun ext => PB.var_computes_fresh ext _)) -/-- The main loop of the Turing machine simulation: Execute a step until we reach a halting -configuration, then return it. -/ -def tmMainLoop (tr : PB) (cfg : PB) : PB := - -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step` - -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep - -- the current `acc` (which has `state = none`, signalling halt to `while_`). - PB.while_ cfg - (fun acc => (singleTapeTMStep tr acc).optionElim acc (fun next => next)) - -lemma tmMainLoop_computes - [Inhabited Symbol] [Fintype Symbol] - {tm : SingleTapeTM Symbol} - [DataEncode tm.State] - {p_tr p_cfg : PB} - {cfg : tm.Cfg} - (h_tr : p_tr.ComputesEnc env - ((Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c')))))) - (h_cfg : p_cfg.ComputesEnc env cfg) - (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) : - (tmMainLoop p_tr p_cfg).ComputesEnc env - ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by - -- Totalise `tm.step`; halting states become fixed points. - set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def - have halt_fix : ∀ c : tm.Cfg, c.state = none → step c = c := by - intro c hc - obtain ⟨s, t⟩ := c - cases s with - | none => simp [step_def] - | some q => simp at hc - -- The head of an encoded `Cfg` is empty iff its state is `none` (the loop's halt condition). - have headEmpty_iff : ∀ c : tm.Cfg, - (DataEncode.encode c).asList.head?.getD (Data.l []) = Data.l [] ↔ c.state = none := by - rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode] - -- One iteration of the loop body computes `step c`. - have body_computes : ∀ c : tm.Cfg, - PB.computesFun₁ env (.data (DataEncode.encode c)) - (fun acc => PB.optionElim (singleTapeTMStep p_tr acc) acc (fun next => next)) - (.data (DataEncode.encode (step c))) := by - intro c - apply PB.computesFun₁_branch - intro ext - have h_acc : (PB.var (env.length + ext.length)).ComputesEnc _ c := PB.var_computes_fresh ext [] - have h_step := singleTapeTMStep_computes (h_tr.extend ext |>.extend _) h_acc - cases hsc : tm.step c with - | none => - rw [show step c = c from by simp only [step_def, hsc, Option.getD_none]] - exact PB.optionElim_computesEnc_none (hsc ▸ h_step) h_acc - | some next => - rw [show step c = next from by simp only [step_def, hsc, Option.getD_some]] - refine PB.optionElim_computesEnc_some (hsc ▸ h_step) - (PB.computesFun₂_branch (fun ext2 => PB.var_computes_fresh ext2 _)) - -- Iterate the body from `c` to its halting configuration after `n` steps. - have loop : ∀ (n : ℕ) (c : tm.Cfg), (step^[n] c).state = none → - PB.WhileComputes env - (fun acc => PB.optionElim (singleTapeTMStep p_tr acc) acc (fun next => next)) - (DataEncode.encode c) (DataEncode.encode (step^[n] c)) := by - intro n - induction n with - | zero => exact fun c hc => PB.WhileComputes.halt ((headEmpty_iff c).mpr hc) - | succ n ih => - intro c hc - by_cases hstate : c.state = none - · rw [Function.iterate_fixed (halt_fix c hstate) (n + 1)] - exact PB.WhileComputes.halt ((headEmpty_iff c).mpr hstate) - · rw [Function.iterate_succ, Function.comp_apply] at hc ⊢ - exact PB.WhileComputes.step - (fun h => hstate ((headEmpty_iff c).mp h)) (body_computes c) (ih (step c) hc) - exact PB.while_computes h_cfg (loop (Nat.find h_halts) cfg (Nat.find_spec h_halts)) - def stringToTape (input : PB) : PB := PB.toPair input.listHeadOption (PB.toPair .empty (input.tail.listMap .some)) @@ -464,14 +393,6 @@ lemma initialConfig_computes [Inhabited Symbol] [Fintype Symbol] (initialConfig p_q₀ p_input).ComputesEnc env (tm.initCfg input) := PB.toPair_computesEnc (PB.some_ComputesEnc h_q₀) (stringToTape_computes h_input) -/-- Compute the final output from the tape contents: the symbol under the head followed by the -contents to its right, with blank (`none`) cells removed. - -This is only meaningful for halting configurations whose tape is in canonical (`mk₁`) form, i.e. -with an empty left part — which is exactly the shape of the `haltCfg`s produced by `Outputs`. -/ -def finalConfigToOutput (cfg : PB) : PB := - (PB.cons (bitapeHead (cfgBitape cfg)) (bitapeRight (cfgBitape cfg))).listReduceOption - def tapeCellsToOutputF (l : List (Option Symbol)) : Option (List Symbol) := l.foldl (fun res s => @@ -512,7 +433,7 @@ lemma tapeCellsToOutput_computes (PB.cons_computesEnc (PB.var_computes_fresh ext2 _) (PB.empty_computesEnc _))) -def tapeToOutputF [DecidableEq Symbol] +def tapeToOutputF (tape : BiTape Symbol) : Option (List Symbol) := if !tape.left.toList.isEmpty then none @@ -528,7 +449,7 @@ def tapeToOutput (tape : PB) : PB := (PB.some .empty) (tapeCellsToOutput (PB.cons (bitapeHead tape) (bitapeRight tape)))) -lemma tapeToOutput_computes [DecidableEq Symbol] +lemma tapeToOutput_computes {p_tape : PB} {tape : BiTape Symbol} (h_tape : p_tape.ComputesEnc env tape) : @@ -561,7 +482,7 @@ lemma tapeCellsToOutputF_eq_some_iff (os : List (Option Symbol)) (r : List Symbo induction os with | nil => rfl | cons o os ih => rw [List.foldl_cons, show F none o = none from by rw [hF]]; exact ih - have key : ∀ (os : List (Option Symbol)) (acc r : List Symbol), + have : ∀ (os : List (Option Symbol)) (acc r : List Symbol), List.foldl F (some acc) os = some r ↔ ∃ l, os = l.map some ∧ r = acc ++ l := by intro os induction os with @@ -592,7 +513,7 @@ lemma tapeCellsToOutputF_eq_some_iff (os : List (Option Symbol)) (r : List Symbo simp only [List.map_cons, List.cons.injEq, Option.some.injEq] at hl obtain ⟨rfl, rfl⟩ := hl exact ⟨l, rfl, by simp [hr]⟩ - rw [key] + rw [this] simp only [List.nil_append] exact ⟨fun ⟨_, hos, hr⟩ => hr ▸ hos, fun hos => ⟨r, hos, rfl⟩⟩ @@ -649,6 +570,174 @@ lemma tapeToOutput_iff_mk₁ [Inhabited Symbol] [DecidableEq Symbol] rw [this] cases s <;> simp [BiTape.mk₁, BiTape.nil, StackTape.nil] + +def timeBoundedSimulator (input : PB) := + let q₀ := input.fst.fst + let tr := input.fst.snd + let inputStr := input.snd.fst + let steps := input.snd.snd + let cfg := timeBoundedSimulatorMain tr (initialConfig q₀ inputStr) steps + PB.boolIte cfg.fst.isNone .none (tapeToOutput cfg.snd) + +def timeBoundedSimulatorF [Inhabited Symbol] [Fintype Symbol] + (tm : SingleTapeTM Symbol) [DataEncode tm.State] + (input : List Symbol) + (steps : ℕ) : Option (List Symbol) := + let cfg := (fun c => (tm.step c).getD c)^[steps] (tm.initCfg input) + if cfg.state.isNone then none else tapeToOutputF cfg.BiTape + +lemma timeBoundedSimulator_computes [Inhabited Symbol] [Fintype Symbol] + {p_input : PB} + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {input : List Symbol} + {steps : ℕ} + (h_input : p_input.ComputesEnc env + ((tm.q₀, (Fintype.elems : Finset tm.State).toList.map fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + fun c' => (c', tm.tr q' c'))), + input, + steps)) : + (timeBoundedSimulator p_input).ComputesEnc env (timeBoundedSimulatorF tm input steps) := by + let h_main := timeBoundedSimulatorMain_computes + (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) + (initialConfig_computes + (PB.fst_ComputesEnc (PB.fst_ComputesEnc h_input)) + (PB.fst_ComputesEnc (PB.snd_ComputesEnc h_input))) + (PB.snd_ComputesEnc (PB.snd_ComputesEnc h_input)) + exact PB.boolIte_computes + (PB.isNone_computes (cfgState_computes h_main)) + PB.none_computes + (tapeToOutput_computes (cfgBitape_computes h_main)) + +/-- Encode `Bool` into an alphabet of size at least 2. -/ +def boolIntoFink {k} : Bool → Fin (k + 2) + | true => 0 + | false => 1 + +/-- The list of all elements of `Fin n`. -/ +def finRange (n : ℕ) : List (Fin n) := + List.ofFn id + +def encodeTM + {k₁ k₂ : ℕ} + (tm : SingleTapeTM (Fin (k₁ + 2))) + (h_state : tm.State = Fin k₂) := + (finRange k₂).map fun q => (q, (finRange (k₁ + 2)).map fun c => (c, tm.tr q c)) + +/-- Defines when a function on binary strings is computable by a TM in a certain time. -/ +def TMTimeComputableBoolFun (f : List Bool → List Bool) (t : ℕ → ℕ) : Prop := + ∃ k₁ k₂, ∃ (tm : SingleTapeTM (Fin (k₁ + 2))), + tm.State = Fin k₂ ∧ + ∀ s, tm.OutputsWithinTime (s.map boolIntoFink) ((f s).map boolIntoFink) (t s.length) + +-- lemma universal_time_bounded_simulator_inner +-- (k₁ k₂ : ℕ) +-- (tm : SingleTapeTM (Fin (k₁ + 2))) +-- (h_state : tm.State = Fin k₂) +-- (input output : List Bool) +-- (steps : ℕ) : +-- ∃ overhead, +-- tm.OutputsWithinTime (input.map boolIntoFink) (output.map boolIntoFink) steps → +-- timeBoundedSimulator.ComputesInTimeAndSpace ( + +-- (timeBoundedSimulatorF tm input steps) = some output +-- else +-- (timeBoundedSimulatorF tm input steps) = none := by sorry + +-- := by + +-- ∀ k₁ k₂, ∀ (tm : SingleTapeTM (Fin (k₁ + 2))), tm.State = Fin k₂ → +-- ∀ll +-- ∀ (f : List Bool → List Bool) t, TMTimeComputableBoolFun f t → +-- ∃ k, ∃ tm : SingleTapeTM (Fin k), tm.State = Fin 0 ∧ +-- ∀ s, tm.OutputsWithinTime (s.map boolIntoFink) ((f s).map boolIntoFink) (t s.length) := by + + +-------------------------------------------------------- +-- The rest is the while-loop based simulator +--------------------------------------------------------- + + +/-- The main loop of the Turing machine simulation: Execute a step until we reach a halting +configuration, then return it. -/ +def tmWhileLoop (tr : PB) (cfg : PB) : PB := + -- The accumulator is the current `Cfg`. The body applies `singleTapeTM_step` + -- (an `Option Cfg`); on `some next` we continue with `next`, on `none` we keep + -- the current `acc` (which has `state = none`, signalling halt to `while_`). + PB.while_ cfg + (fun acc => (singleTapeTMStep tr acc).optionElim acc (fun next => next)) + +lemma tmWhileLoop_computes + [Inhabited Symbol] [Fintype Symbol] + {tm : SingleTapeTM Symbol} + [DataEncode tm.State] + {p_tr p_cfg : PB} + {cfg : tm.Cfg} + (h_tr : p_tr.ComputesEnc env + ((Fintype.elems : Finset tm.State).toList.map (fun q' => + (q', (Fintype.elems : Finset (Option Symbol)).toList.map + (fun c' => (c', tm.tr q' c')))))) + (h_cfg : p_cfg.ComputesEnc env cfg) + (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) : + (tmWhileLoop p_tr p_cfg).ComputesEnc env + ((fun c => (tm.step c).getD c)^[Nat.find h_halts] cfg) := by + -- Totalise `tm.step`; halting states become fixed points. + set step : tm.Cfg → tm.Cfg := fun c => (tm.step c).getD c with step_def + have halt_fix : ∀ c : tm.Cfg, c.state = none → step c = c := by + intro c hc + obtain ⟨s, t⟩ := c + cases s with + | none => simp [step_def] + | some q => simp at hc + -- The head of an encoded `Cfg` is empty iff its state is `none` (the loop's halt condition). + have headEmpty_iff : ∀ c : tm.Cfg, + (DataEncode.encode c).asList.head?.getD (Data.l []) = Data.l [] ↔ c.state = none := by + rintro ⟨s, t⟩; cases s <;> simp [DataEncode.encode] + -- One iteration of the loop body computes `step c`. + have body_computes : ∀ c : tm.Cfg, + PB.computesFun₁ env (.data (DataEncode.encode c)) + (fun acc => PB.optionElim (singleTapeTMStep p_tr acc) acc (fun next => next)) + (.data (DataEncode.encode (step c))) := by + intro c + apply PB.computesFun₁_branch + intro ext + have h_acc : (PB.var (env.length + ext.length)).ComputesEnc _ c := PB.var_computes_fresh ext [] + have h_step := singleTapeTMStep_computes (h_tr.extend ext |>.extend _) h_acc + cases hsc : tm.step c with + | none => + rw [show step c = c from by simp only [step_def, hsc, Option.getD_none]] + exact PB.optionElim_computesEnc_none (hsc ▸ h_step) h_acc + | some next => + rw [show step c = next from by simp only [step_def, hsc, Option.getD_some]] + refine PB.optionElim_computesEnc_some (hsc ▸ h_step) + (PB.computesFun₂_branch (fun ext2 => PB.var_computes_fresh ext2 _)) + -- Iterate the body from `c` to its halting configuration after `n` steps. + have loop : ∀ (n : ℕ) (c : tm.Cfg), (step^[n] c).state = none → + PB.WhileComputes env + (fun acc => PB.optionElim (singleTapeTMStep p_tr acc) acc (fun next => next)) + (DataEncode.encode c) (DataEncode.encode (step^[n] c)) := by + intro n + induction n with + | zero => exact fun c hc => PB.WhileComputes.halt ((headEmpty_iff c).mpr hc) + | succ n ih => + intro c hc + by_cases hstate : c.state = none + · rw [Function.iterate_fixed (halt_fix c hstate) (n + 1)] + exact PB.WhileComputes.halt ((headEmpty_iff c).mpr hstate) + · rw [Function.iterate_succ, Function.comp_apply] at hc ⊢ + exact PB.WhileComputes.step + (fun h => hstate ((headEmpty_iff c).mp h)) (body_computes c) (ih (step c) hc) + exact PB.while_computes h_cfg (loop (Nat.find h_halts) cfg (Nat.find_spec h_halts)) + + +/-- Compute the final output from the tape contents: the symbol under the head followed by the +contents to its right, with blank (`none`) cells removed. + +This is only meaningful for halting configurations whose tape is in canonical (`mk₁`) form, i.e. +with an empty left part — which is exactly the shape of the `haltCfg`s produced by `Outputs`. -/ +def finalConfigToOutput (cfg : PB) : PB := + (PB.cons (bitapeHead (cfgBitape cfg)) (bitapeRight (cfgBitape cfg))).listReduceOption + lemma finalConfigToOutput_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {p_cfg : PB} {cfg : tm.Cfg} @@ -661,7 +750,7 @@ lemma finalConfigToOutput_computes [Inhabited Symbol] [Fintype Symbol] (bitapeRight_computes (cfgBitape_computes h_cfg))) def tmSimulator (input : PB) := - finalConfigToOutput (tmMainLoop input.fst.snd (initialConfig input.fst.fst input.snd)) + finalConfigToOutput (tmWhileLoop input.fst.snd (initialConfig input.fst.fst input.snd)) /-- Translate Relation.ReflTransGen, the construct underlying `SingleTapeTM.Outputs`, into iteration of the step function. -/ @@ -700,7 +789,7 @@ omit env [DataEncode Symbol] in /-- If the totalised step function reaches a halting configuration `y` after `N` iterations, then it also reaches `y` at the *first* halting index `Nat.find h_halts` (halting configurations are fixpoints of the totalised step, so the orbit stabilises). This bridges -`reflTransGen_iff_exists_iter` (which gives *some* witness `N`) and `tmMainLoop_computes` (whose +`reflTransGen_iff_exists_iter` (which gives *some* witness `N`) and `tmWhileLoop_computes` (whose result is indexed by `Nat.find h_halts`). -/ private lemma iterate_find_state_eq [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} @@ -760,13 +849,13 @@ lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] -- From `Outputs`, the totalised step reaches `haltCfg output` after some `N` iterations. obtain ⟨N, hN⟩ := (reflTransGen_iff_exists_iter tm.step (x := tm.initCfg input) (y := tm.haltCfg output)).mp h_outputs - -- Hence it eventually reaches a halting state, and `tmMainLoop` computes that config. + -- Hence it eventually reaches a halting state, and `tmWhileLoop` computes that config. have h_halts : ∃ n, ((fun c => (tm.step c).getD c)^[n] (tm.initCfg input)).state = none := ⟨N, by rw [hN]; rfl⟩ have h_main : - (tmMainLoop p_input.fst.snd (initialConfig p_input.fst.fst p_input.snd)).ComputesEnc + (tmWhileLoop p_input.fst.snd (initialConfig p_input.fst.fst p_input.snd)).ComputesEnc env (tm.haltCfg output) := by - have := tmMainLoop_computes (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) h_cfg h_halts + have := tmWhileLoop_computes (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) h_cfg h_halts rwa [iterate_find_state_eq hN rfl h_halts] at this -- The simulator extracts the output from the halting configuration's canonical tape. have hval : ((tm.haltCfg output).BiTape.head :: From 91746dfbec4090fd6866f33c95fa8425066f79c5 Mon Sep 17 00:00:00 2001 From: crei Date: Thu, 18 Jun 2026 11:47:29 +0200 Subject: [PATCH 17/22] Generalize function evaluation. --- .../Machines/RTM/TMSimulator.lean | 144 ++++++++++-------- Cslib/Computability/Machines/RTM/Tools.lean | 35 +++-- 2 files changed, 105 insertions(+), 74 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 131c9474e..fdaf60661 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -250,23 +250,28 @@ instance : DataEncode (SingleTapeTM.Stmt Symbol) where have heq := DataEncode.h_inj h grind -lemma evalTr_computes {State : Type} [Fintype State] [DataEncode State] - [Fintype Symbol] +/-- `evalTr` evaluates the transition function if it is given a graph of it as input. -/ +lemma evalTr_computes {State : Type} [DataEncode State] {p_tr p_q p_c : PB} {tr : State → Option Symbol → SingleTapeTM.Stmt Symbol × Option State} + {stateEnum : List State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) {q : State} {c : Option Symbol} (h_tr : p_tr.ComputesEnc env - ((Fintype.elems : Finset State).toList.map (fun q' : State => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' : Option Symbol => (c', tr q' c')))))) + (stateEnum.map (fun q' : State => + (q', symEnum.map (fun c' : Option Symbol => (c', tr q' c')))))) (h_q : p_q.ComputesEnc env q) (h_c : p_c.ComputesEnc env c) : (evalTr p_tr p_q p_c).ComputesEnc env (tr q c) := by + classical exact PB.evalFunGraph_Computes_of_fun (α := Option Symbol) (f := tr q) - (PB.evalFunGraph_Computes_of_fun (α := State) (f := fun q' => - (Fintype.elems : Finset (Option Symbol)).toList.map (fun c' => (c', tr q' c'))) - h_tr h_q) h_c + (PB.evalFunGraph_Computes_of_fun (α := State) + (f := fun q' => symEnum.map (fun c' => (c', tr q' c'))) + h_tr (PB.IsGraphOf.of_complete h_stateEnum) h_q) + (PB.IsGraphOf.of_complete h_symEnum) h_c /-- The part of `SingleTapeTM.step` that applies the output of the transition function to the configuration. -/ @@ -303,12 +308,15 @@ lemma singleTapeTMStep_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {stateEnum : List tm.State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) {p_tr p_cfg : PB} {cfg : tm.Cfg} (h_tr : p_tr.ComputesEnc env - ((Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c')))))) + (stateEnum.map (fun q' => + (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))) (h_cfg : p_cfg.ComputesEnc env cfg) : (singleTapeTMStep p_tr p_cfg).ComputesEnc env (tm.step cfg) := by obtain ⟨state, t⟩ := cfg @@ -322,7 +330,8 @@ lemma singleTapeTMStep_computes apply PB.computesFun₂_branch intro ext refine applyTrVal_computes ?_ (h_cfg.extend ext |>.extend _) - refine evalTr_computes (h_tr.extend ext |>.extend _) (PB.var_computes_fresh ext _) ?_ + refine evalTr_computes h_stateEnum h_symEnum + (h_tr.extend ext |>.extend _) (PB.var_computes_fresh ext _) ?_ exact PB.head_computes (cfgBitape_computes (h_cfg.extend ext |>.extend _)) /-- Run the step function for `steps` iterations, staying at a halting configuration. -/ @@ -336,10 +345,13 @@ lemma timeBoundedSimulatorMain_computes {p_tr p_cfg p_steps : PB} {cfg : tm.Cfg} {steps : ℕ} + {stateEnum : List tm.State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) (h_tr : p_tr.ComputesEnc env - ((Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c')))))) + (stateEnum.map (fun q' => + (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))) (h_cfg : p_cfg.ComputesEnc env cfg) (h_steps : p_steps.ComputesEnc env steps) : (timeBoundedSimulatorMain p_tr p_cfg p_steps).ComputesEnc env @@ -355,7 +367,7 @@ lemma timeBoundedSimulatorMain_computes apply PB.forLoop_computes (f := fun _ c => (tm.step c).getD c) h_steps h_cfg intro e pi pacc i c hpre h_pi h_acc obtain ⟨more, rfl⟩ := hpre - have hstep := singleTapeTMStep_computes (h_tr.extend more) h_acc + have hstep := singleTapeTMStep_computes h_stateEnum h_symEnum (h_tr.extend more) h_acc cases hsc : tm.step c with | none => exact PB.optionElim_computesEnc_none (hsc ▸ hstep) h_acc | some next => @@ -518,7 +530,7 @@ lemma tapeCellsToOutputF_eq_some_iff (os : List (Option Symbol)) (r : List Symbo exact ⟨fun ⟨_, hos, hr⟩ => hr ▸ hos, fun hos => ⟨r, hos, rfl⟩⟩ omit [DataEncode Symbol] in -lemma tapeToOutput_iff_mk₁ [Inhabited Symbol] [DecidableEq Symbol] +lemma tapeToOutput_iff_mk₁ [Inhabited Symbol] (tape : BiTape Symbol) (s : List Symbol) : (tape = .mk₁ s) ↔ tapeToOutputF tape = some s := by obtain ⟨hd, lft, rgt⟩ := tape @@ -591,14 +603,19 @@ lemma timeBoundedSimulator_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {input : List Symbol} {steps : ℕ} + {stateEnum : List tm.State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) (h_input : p_input.ComputesEnc env - ((tm.q₀, (Fintype.elems : Finset tm.State).toList.map fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - fun c' => (c', tm.tr q' c'))), + ((tm.q₀, (stateEnum.map (fun q' => + (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))), input, steps)) : (timeBoundedSimulator p_input).ComputesEnc env (timeBoundedSimulatorF tm input steps) := by let h_main := timeBoundedSimulatorMain_computes + h_stateEnum + h_symEnum (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) (initialConfig_computes (PB.fst_ComputesEnc (PB.fst_ComputesEnc h_input)) @@ -618,40 +635,34 @@ def boolIntoFink {k} : Bool → Fin (k + 2) def finRange (n : ℕ) : List (Fin n) := List.ofFn id -def encodeTM - {k₁ k₂ : ℕ} - (tm : SingleTapeTM (Fin (k₁ + 2))) - (h_state : tm.State = Fin k₂) := - (finRange k₂).map fun q => (q, (finRange (k₁ + 2)).map fun c => (c, tm.tr q c)) - -/-- Defines when a function on binary strings is computable by a TM in a certain time. -/ -def TMTimeComputableBoolFun (f : List Bool → List Bool) (t : ℕ → ℕ) : Prop := - ∃ k₁ k₂, ∃ (tm : SingleTapeTM (Fin (k₁ + 2))), - tm.State = Fin k₂ ∧ - ∀ s, tm.OutputsWithinTime (s.map boolIntoFink) ((f s).map boolIntoFink) (t s.length) - --- lemma universal_time_bounded_simulator_inner --- (k₁ k₂ : ℕ) --- (tm : SingleTapeTM (Fin (k₁ + 2))) --- (h_state : tm.State = Fin k₂) --- (input output : List Bool) --- (steps : ℕ) : --- ∃ overhead, --- tm.OutputsWithinTime (input.map boolIntoFink) (output.map boolIntoFink) steps → --- timeBoundedSimulator.ComputesInTimeAndSpace ( - --- (timeBoundedSimulatorF tm input steps) = some output --- else --- (timeBoundedSimulatorF tm input steps) = none := by sorry - --- := by - --- ∀ k₁ k₂, ∀ (tm : SingleTapeTM (Fin (k₁ + 2))), tm.State = Fin k₂ → --- ∀ll --- ∀ (f : List Bool → List Bool) t, TMTimeComputableBoolFun f t → --- ∃ k, ∃ tm : SingleTapeTM (Fin k), tm.State = Fin 0 ∧ --- ∀ s, tm.OutputsWithinTime (s.map boolIntoFink) ((f s).map boolIntoFink) (t s.length) := by - +noncomputable def encodeTMTr {k₁ : ℕ} (tm : SingleTapeTM (Fin (k₁ + 2))) := + (Fintype.elems : Finset tm.State).toList.map fun q => (q, + (Fintype.elems : Finset (Option (Fin (k₁ + 2)))).toList.map fun c => (c, tm.tr q c)) + +instance {k : ℕ} : DataEncode (Fin k) where + encode x := DataEncode.encode x.val + h_inj := by grind [DataEncode.h_inj, Function.Injective] + +lemma universal_time_bounded_simulator_inner : + ∃ overhead : ℕ, ∀ + {k₁ : ℕ} + (tm : SingleTapeTM (Fin (k₁ + 2))) + [DataEncode tm.State] + (input output : List Bool) + (steps : ℕ), + tm.OutputsWithinTime (input.map boolIntoFink) (output.map boolIntoFink) steps ↔ + ∃ s, + PB.ComputesInTimeAndSpace + timeBoundedSimulator + ((tm.q₀, encodeTMTr tm), input, steps) + (Option.some output) + -- The simulation has quadratic overhead (`steps * steps`), but it is independent + -- of the input size. + (overhead * (DataEncode.encode (encodeTMTr tm)).size * steps * steps + + overhead * (DataEncode.encode (encodeTMTr tm)).size) + s + := by + sorry -------------------------------------------------------- -- The rest is the while-loop based simulator @@ -673,10 +684,13 @@ lemma tmWhileLoop_computes [DataEncode tm.State] {p_tr p_cfg : PB} {cfg : tm.Cfg} + {stateEnum : List tm.State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) (h_tr : p_tr.ComputesEnc env - ((Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c')))))) + (stateEnum.map (fun q' : tm.State => + (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))) (h_cfg : p_cfg.ComputesEnc env cfg) (h_halts : ∃ n, (((fun c => (tm.step c).getD c)^[n] cfg)).state = none) : (tmWhileLoop p_tr p_cfg).ComputesEnc env @@ -702,7 +716,8 @@ lemma tmWhileLoop_computes apply PB.computesFun₁_branch intro ext have h_acc : (PB.var (env.length + ext.length)).ComputesEnc _ c := PB.var_computes_fresh ext [] - have h_step := singleTapeTMStep_computes (h_tr.extend ext |>.extend _) h_acc + have h_step := singleTapeTMStep_computes h_stateEnum h_symEnum + (h_tr.extend ext |>.extend _) h_acc cases hsc : tm.step c with | none => rw [show step c = c from by simp only [step_def, hsc, Option.getD_none]] @@ -835,11 +850,13 @@ lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] {p_input : PB} {input output : List Symbol} + {stateEnum : List tm.State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) (h_input : p_input.ComputesEnc env - ((tm.q₀, - (Fintype.elems : Finset tm.State).toList.map (fun q' => - (q', (Fintype.elems : Finset (Option Symbol)).toList.map - (fun c' => (c', tm.tr q' c'))))), + ((tm.q₀, (stateEnum.map (fun q' => + (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))), input)) : tm.Outputs input output → (tmSimulator p_input).ComputesEnc env output := by intro h_outputs @@ -855,7 +872,8 @@ lemma tmSimulatorComputes [Inhabited Symbol] [Fintype Symbol] have h_main : (tmWhileLoop p_input.fst.snd (initialConfig p_input.fst.fst p_input.snd)).ComputesEnc env (tm.haltCfg output) := by - have := tmWhileLoop_computes (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) h_cfg h_halts + have := tmWhileLoop_computes h_stateEnum h_symEnum + (PB.snd_ComputesEnc (PB.fst_ComputesEnc h_input)) h_cfg h_halts rwa [iterate_find_state_eq hN rfl h_halts] at this -- The simulator extracts the output from the halting configuration's canonical tape. have hval : ((tm.haltCfg output).BiTape.head :: diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index f49f54499..e67462ae0 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -485,24 +485,37 @@ lemma evalFunGraph_computes exact snd_ComputesEnc (while_computes h_init (h_loop graph)) +/-- `graph` is a lookup table for `f`: looking up any key `a` yields `f a`. -/ +def IsGraphOf {α β : Type} [DecidableEq α] (graph : List (α × β)) (f : α → β) : Prop := + ∀ a, (graph.find? (fun p => p.1 = a)).map (·.2) = Option.some (f a) + +/-- Any complete enumeration of the keys yields a lookup table for `f`. -/ +lemma IsGraphOf.of_complete {α β : Type} [DecidableEq α] + {graph_enum : List α} + {f : α → β} + (h : ∀ a, a ∈ graph_enum) : + IsGraphOf (graph_enum.map fun a => (a, f a)) f := by + intro a + suffices hsuff : ∀ L : List α, a ∈ L → + ((L.map fun a' => (a', f a')).find? (fun p => p.1 = a)).map (·.2) = Option.some (f a) from + hsuff graph_enum (h a) + intro L hmem + induction L with + | nil => exact absurd hmem (by simp) + | cons hd tl ih => grind + lemma evalFunGraph_Computes_of_fun - [Fintype α] + [DecidableEq α] {p_graph p_arg : PB} + {graph : List (α × β)} {a : α} {f : α → β} - (h_graph : p_graph.ComputesEnc env (Fintype.elems.toList.map (fun a => (a, f a)))) + (h_graph : p_graph.ComputesEnc env graph) + (h_isGraph : IsGraphOf graph f) (h_arg : p_arg.ComputesEnc env a) : (PB.evalFunGraph p_graph p_arg).head.ComputesEnc env (f a) := by - classical - have heq : ∀ (L : List α), a ∈ L → - ((L.map (fun a' => (a', f a'))).find? - (fun p => p.1 = a)).map (·.2) = Option.some (f a) := by - intro L hmem - induction L with - | nil => exact absurd hmem (by simp) - | cons hd tl ih => grind have h := PB.evalFunGraph_computes h_graph h_arg - rw [heq _ (Finset.mem_toList.mpr (Fintype.complete a))] at h + rw [h_isGraph a] at h apply PB.head_computes h From c4bb5f294dcbfbd44fc76ba18670ba97c311dabf Mon Sep 17 00:00:00 2001 From: crei Date: Mon, 22 Jun 2026 11:30:26 +0200 Subject: [PATCH 18/22] State the complexity in terms of functions accepting variables instead of full programs. --- .../Machines/RTM/DataEncode.lean | 3 + Cslib/Computability/Machines/RTM/PB.lean | 159 ++++++++++++++++-- Cslib/Computability/Machines/RTM/Prog.lean | 97 +++++++---- .../Machines/RTM/TMSimulator.lean | 84 ++++++++- Cslib/Computability/Machines/RTM/Tools.lean | 31 +++- 5 files changed, 316 insertions(+), 58 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/DataEncode.lean b/Cslib/Computability/Machines/RTM/DataEncode.lean index 84bebca95..2279c8259 100644 --- a/Cslib/Computability/Machines/RTM/DataEncode.lean +++ b/Cslib/Computability/Machines/RTM/DataEncode.lean @@ -36,6 +36,9 @@ instance : DataEncode Data where encode b := b h_inj := by intros a b h_eq; grind +@[simp, scoped grind =] +lemma DataEncode_encode_data (d : Data) : DataEncode.encode d = d := rfl + instance : DataEncode Bool where encode b := if b then Data.l [ Data.l [] ] else Data.l [] h_inj := by intros a b h_eq; grind diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index e31f04b53..ec505b31a 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -58,6 +58,9 @@ namespace Turing namespace RoseTreeMachine +-- TODO we should distinguish at the type level between Var (a variable / reference to a slot) +-- and ℕ (the environment depth) + /-- A program builder: given the current binder depth (the size of `env` at the point of insertion), produce a `Prog`. -/ abbrev PB := ℕ → Prog @@ -72,15 +75,21 @@ def elim (v em : PB) (cs : PB → PB → PB) : PB := fun n => def ifEq (x y then_ else_ : PB) : PB := fun n => .ifEq (x n) (y n) (then_ n) (else_ n) def while_ (init : PB) (body : PB → PB) : PB := fun n => .while_ (init n) (.fn (body (var n) (n + 1))) -def fn (body : PB → PB) : PB := fun n => .fn (body (var n) (n + 1)) +def fn (body : ℕ → PB) : PB := fun n => .fn (body n (n + 1)) def app (f a : PB) : PB := fun n => .app (f n) (a n) +def letIn (e : PB) (body : ℕ → PB) : PB := app (fn body) e + +macro "PBlet " x:ident ":=" e:term " in " body:term : term => do + `(PB.letIn $e (fun $x => $body)) + /-- Close a builder into a concrete `Prog`. -/ def build (p : PB) : Prog := p 0 variable {env : List Value} + /-! ### Resource-erased (`ProgSem`-based) semantics for program builders `PB.computes env impl out` says that, under any outer extension `ext`, the builder unfolded at @@ -114,6 +123,54 @@ This allows statements that `PB`s compute functions on lean datatypes. -/ def ComputesEnc {α : Type} [DataEncode α] (env : List Value) (impl : PB) (x : α) := Computes env impl (.data (DataEncode.encode x)) +def EnvEnc {α : Type} [DataEncode α] (env : List Value) (var : ℕ) (x : α) := + ∀ ext, (env ++ ext)[var]?.getD Value.empty = .data (DataEncode.encode x) + + +------------------- Resource Consumption ------------------------- + +@[scoped grind =] +def envSize (env : List Value) : ℕ := env.map (fun x : Value => x.size) |>.sum + +def TimeBounded (env : List Value) (impl : PB) (t : ℕ) := + ∀ x t' s, ProgSem env (impl env.length) x t' s → t' ≤ t + +def SpaceBounded (env : List Value) (impl : PB) (s : ℕ) := + ∀ x t s', ProgSem env (impl env.length) x t s' → s' ≤ s + +def OTime (impl : PB) (t : List Value → ℕ) := + ∃ k, ∀ env, TimeBounded env impl (k * (t env) + k) + +def OSpace (impl : PB) (s : List Value → ℕ) := + ∃ k, ∀ env, SpaceBounded env impl (k * (s env) + k) + +def OTimeFun₁ (impl : PB → PB) (t : List Value → ℕ) := + ∃ k, ∀ env x y t' s, ProgSem (env ++ [x]) (impl (.var env.length) (env.length + 1)) y t' s → + t' ≤ k * (t (env ++ [x])) + k + +def OSpaceFun₁ (impl : PB → PB) (s : List Value → ℕ) := + ∃ k, ∀ env x y t s', ProgSem (env ++ [x]) (impl (.var env.length) (env.length + 1)) y t s' → + s' ≤ k * (s (env ++ [x])) + k + +def OTimeFun₂ (impl : PB → PB → PB) (t : List Value → ℕ) := + ∃ k, ∀ env x y z t' s, ProgSem (env ++ [x, y]) + (impl (.var env.length) (.var (env.length + 1)) (env.length + 2)) z t' s → + t' ≤ k * (t (env ++ [x, y])) + k + +def OSpaceFun₂ (impl : PB → PB → PB) (s : List Value → ℕ) := + ∃ k, ∀ env x y z t s', ProgSem (env ++ [x, y]) + (impl (.var env.length) (.var (env.length + 1)) (env.length + 2)) z t s' → + s' ≤ k * (s (env ++ [x, y])) + k + +/-- The space and time complexity of `impl` is linear in the size of the environment. +Note that this is more or less the best complexity we can have. -/ +def Linear (impl : PB) := OTime impl envSize ∧ OSpace impl envSize + +def LinearFun₂ (impl : PB → PB → PB) := + OTimeFun₂ impl envSize ∧ OSpaceFun₂ impl envSize + +--------------------- Lemmas for combinators ------------------------------- + /-- Var-lookup: `PB.var i` reads the `i`-th entry of the environment. -/ @[simp] lemma var_computes {i : ℕ} (h : i < env.length) : @@ -151,6 +208,13 @@ lemma var_computes_fresh2 {v w : Value} (ext binds : List Value) : Computes (env ++ ext ++ (v :: w :: binds)) (PB.var (env.length + ext.length + 1)) w := by exact var_computes_fresh' ext (v :: w :: binds) (j := 1) (by simp) +lemma var_computes_of_envEnc {α : Type} [DataEncode α] {var : ℕ} {x : α} (h : EnvEnc env var x) : + Computes env (PB.var var) (.data (DataEncode.encode x)) := by + intro ext + exact ⟨_, _, (h ext) ▸ ProgSem.var⟩ + +lemma empty_linear : Linear (PB.empty) := by sorry + @[simp] lemma empty_computes : Computes env empty (.data (.l [])) := by intro ext @@ -178,6 +242,10 @@ lemma cons_computesEnc {α : Type} [DataEncode α] {p_hd p_tl : PB} {hd : α} {t obtain ⟨tt, st, ht'⟩ := h_tl ext exact ⟨_, _, ProgSem.cons hh' ht'⟩ +lemma cons_linear {h t : PB} (hh : Linear h) (ht : Linear t) : + Linear (PB.cons h t) := by + sorry + /-- A `PB.var` at the absolute level of the `j`-th freshly-bound variable reads `binds[j]`. -/ @[simp] lemma var_computesFun {binds : List Value} {j : ℕ} (ext : List Value) : @@ -190,6 +258,16 @@ lemma var_computesFun {binds : List Value} {j : ℕ} (ext : List Value) : rw [e1, List.getElem?_append_right (Nat.le_add_right _ _), Nat.add_sub_cancel_left] exact ⟨_, _, hval ▸ ProgSem.var⟩ +/-- Inversion for a variable lookup: a `.var i` derivation reads `σ[i]` and charges exactly its +size for both time and space. -/ +lemma ProgSem.var_inv {σ : List Value} {i : ℕ} {v : Value} {t s : ℕ} + (h : ProgSem σ (.var i) v t s) : + v = σ[i]?.getD Value.empty ∧ t = v.size ∧ s = v.size := by + cases h + exact ⟨rfl, rfl, rfl⟩ + +lemma var_linear {i : ℕ} : Linear (PB.var i) := by sorry + /-- The code in `body` computes a function of two arguments `x`, `y` and returns `out`. -/ def computesFun₂ (env : List Value) (x y : Value) (body : PB → PB → PB) (out : Value) : Prop := ∀ ext : List Value, ∃ t s, ProgSem (env ++ ext ++ [x, y]) @@ -228,6 +306,14 @@ def computesFun₁ (env : List Value) (x : Value) (body : PB → PB) (out : Valu (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1)) out t s +/-- The code in `body` computes a function of one argument `x` and returns `out`. +-- TODO use this instead of the above -/ +def computesFun₁v (env : List Value) (x : Value) (body : ℕ → PB) (out : Value) : Prop := + ∀ ext : List Value, ∃ t s, ProgSem (env ++ ext ++ [x]) + (body (env.length + ext.length) (env.length + ext.length + 1)) + out t s + + /-- To run a one-argument body on its freshly-bound argument, it suffices that `body` applied to the fresh variable computes `out` in the extended environment. This hides the `Computes.here`/length bookkeeping of `computesFun₁` (the one-argument analogue of @@ -273,6 +359,22 @@ lemma elim_cons_computes {v em : PB} {cs : PB → PB → PB} rw [hmap]; exact hb exact ⟨_, _, ProgSem.elim_cons hv' ProgSem.fn (AppSem.mk ProgSem.fn) (AppSem.mk hb')⟩ +lemma elim_linear + {v em : PB} {cs : PB → PB → PB} + (h_v : Linear v) + (h_em : Linear em) + (h_cs : LinearFun₂ cs) : + Linear (PB.elim v em cs) := by + sorry + +lemma elim_time {v em : PB} {cs : PB → PB → PB} + {t_v t_em t_cs : List Value → ℕ} + (h_v : OTime v t_v) + (h_em : OTime em t_em) + (h_cs : OTimeFun₂ cs t_cs) : + OTime (PB.elim v em cs) (fun env => t_v env + t_em env + t_cs env) := by sorry + + @[simp] lemma ifeq_eq_computes {x y then_ else_ : PB} {vx : Data} {out : Value} (hx : Computes env x (.data vx)) @@ -313,9 +415,9 @@ lemma ifeq_computes {x y then_ else_ : PB} {vx vy : Data} {out₁ out₂ : Value /-- In-place application of a literal abstraction (a `let` binding): if `arg` computes `dx` and `body` computes `out` with its parameter bound to `dx`, then `app (fn body) arg` computes `out`. -/ -lemma app_fn_computes {body : PB → PB} {arg : PB} {dx out : Value} +lemma app_fn_computes {body : ℕ → PB} {arg : PB} {dx out : Value} (harg : Computes env arg dx) - (hbody : computesFun₁ env dx body out) : + (hbody : computesFun₁v env dx body out) : Computes env (PB.app (PB.fn body) arg) out := by intro ext obtain ⟨ta, sa, ha⟩ := harg ext @@ -325,7 +427,7 @@ lemma app_fn_computes {body : PB → PB} {arg : PB} {dx out : Value} = (env ++ ext ++ [dx]) := by simp have hb' : ProgSem ((env ++ ext) ++ [dx]) - (body (PB.var (env.length + ext.length)) (env.length + ext.length + 1)) + (body (env.length + ext.length) (env.length + ext.length + 1)) out tb sb := by rw [hmap]; exact hb exact ⟨_, _, ProgSem.app ProgSem.fn ha (AppSem.mk hb')⟩ @@ -408,6 +510,26 @@ theorem WhileComputes.rec' {body : PB → PB} (μ : Data → ℕ) (result : Data ------------------- Resource Consumption ------------------------- +-- /-- Resource-erased relational semantics of a program builder. -/ +-- def UsesTimeAndSpace (env : List Value) (impl : PB) (t s : ℕ) : Prop := +-- ∀ ext : List Value, +-- ∃ out, ProgSem (env ++ ext) (impl (env.length + ext.length)) +-- out t s + +-- def LinearOverhead (impl : PB → PB) : Prop := +-- ∃ k, ∀ env p t s, +-- UsesTimeAndSpace env p t s → +-- ∃ t' ≤ k * t + k, ∃ s' ≤ k * s + k, +-- UsesTimeAndSpace env (impl p) t' s' + +-- def LinearOverhead₂ (impl : PB → PB → PB) : Prop := +-- ∃ k, ∀ env p₁ p₂ t₁ s₁ t₂ s₂, +-- UsesTimeAndSpace env p₁ t₁ s₁ → +-- UsesTimeAndSpace env p₂ t₂ s₂ → +-- ∃ t' ≤ k * (t₁ + t₂) + k, ∃ s' ≤ k * (s₁ + s₂) + k, +-- UsesTimeAndSpace env (impl p₁ p₂) t' s' + + def OutputsOSize (impl : PB) (s : List Value → ℕ) : Prop := ∃ a b, ∀ env, ∃ out, impl.Computes env out ∧ out.size ≤ a * (s env) + b @@ -424,23 +546,28 @@ def UsesLinearTimeAndSpace (impl : PB) : Prop := PB.UsesOTime impl (fun env => (env.map fun x => x.size).sum) ∧ PB.UsesOSpace impl (fun env => (env.map fun x => x.size).sum) -def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] - (p : PB → PB) (x : α) (y : β) (t s : α → ℕ) : Prop := - ∀ (env : List Value) (a : PB) (ta sa : ℕ), +-- def ComputesInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] +-- (env : List Value) (p : PB) (y : β) (t s : ℕ) : Prop := +-- ∀ ext, ProgSem (env ++ ext) (p (env.length + ext.length)) +-- (.data (DataEncode.encode y)) t s + +def ComputesFunInAdditionalTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] + (env : List Value) (p : PB → PB) (x : α) (y : β) (t s : α → ℕ) : Prop := + ∀ (a : PB) (ta sa : ℕ), (∀ ext, ProgSem (env ++ ext) (a (env.length + ext.length)) (.data (DataEncode.encode x)) ta sa) → (∀ ext, ∃ t' ≤ t x, ∃ s' ≤ s x, ProgSem (env ++ ext) (p a (env.length + ext.length)) - (.data (DataEncode.encode y)) (t' + ta) (max s' sa)) + (.data (DataEncode.encode y)) (t' + ta) (s' + sa)) -def ComputesFunInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] - (p : PB → PB) (φ : α → β) (t s : α → ℕ) : Prop := - ∀ x, ComputesInTimeAndSpace p x (φ x) t s +-- def ComputesFunInTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] +-- (p : PB → PB) (φ : α → β) (t s : α → ℕ) : Prop := +-- ∀ x, ComputesFunInAdditionalTimeAndSpace p x (φ x) t s -def ComputesFunInLinearTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] - (p : PB → PB) (φ : α → β) : Prop := - ∃ k, ComputesFunInTimeAndSpace p φ - (fun x => k * (DataEncode.encode x).size + k) - (fun x => k * (DataEncode.encode x).size + k) +-- def ComputesFunInLinearTimeAndSpace {α β : Type} [DataEncode α] [DataEncode β] +-- (p : PB → PB) (φ : α → β) : Prop := +-- ∃ k, ComputesFunInTimeAndSpace p φ +-- (fun x => k * (DataEncode.encode x).size + k) +-- (fun x => k * (DataEncode.encode x).size + k) end PB diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index 53db58915..a662bc302 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -72,19 +72,37 @@ inductive Value where | closure (body : Prog) (env : List Value) deriving Repr -def Value.size : Value → ℕ - | .data d => d.size - | .closure _ env => 2 + (env.map Value.size).sum - abbrev Value.empty : Value := .data (Data.l []) -@[simp] -lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size] +def Prog.hasVar (i : ℕ) : Prog → Bool + | .var j => i = j + | .empty => false + | .cons h t => h.hasVar i || t.hasVar i + | .elim v emp cs => v.hasVar i || emp.hasVar i || cs.hasVar i + | .ifEq x y then_ else_ => + x.hasVar i || y.hasVar i || then_.hasVar i || else_.hasVar i + | .while_ init body => init.hasVar i || body.hasVar i + | .fn body => body.hasVar i + | .app f arg => f.hasVar i || arg.hasVar i -lemma Value.size_pos {v : Value} : 0 < v.size := by - cases v with - | data d => simp only [Value.size]; exact Data.size_le - | closure _ env => simp only [Value.size]; omega + +mutual + def closureSize (body : Prog) (env : List Value) : ℕ := + let rec go (depth : ℕ) (env : List Value) : ℕ := + match env with + | [] => 0 + | hd :: tl => go (depth + 1) tl + if body.hasVar depth then hd.size else 0 + go 0 env + + /-- The size of a `Value`. The size of data is the length of its encoding and the size + of a closure is the sum of the sizes of the referenced variables. -/ + def Value.size : Value → ℕ + | .data d => d.size + | .closure p env => closureSize p env +end + +@[simp, scoped grind =] +lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size] mutual /-- Semantics of `Prog` including time and space resource bounds. @@ -101,51 +119,38 @@ inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop | elim_nil (h₁ : ProgSem σ val (.data (Data.l [])) t_v s_v) (h₂ : ProgSem σ emp r t_emp s_emp) : - ProgSem σ (.elim val emp cs) r (t_v + t_emp) (max s_v s_emp) + ProgSem σ (.elim val emp cs) r (t_v + t_emp) (s_v + s_emp) /-- `elim`, cons branch: `v` destructures to `hd :: tl`; evaluate the function `cs` to a closure and apply it first to `hd` and then to `tl` (so `cs` is a curried - two-argument function). - TODO: We could syntactically require that the `cs` argument always has the form - `.fn .fn ...`, then we could change the cost function so that we do not need to charge - for creating the closure (and the same for all similar constructs). - -/ + two-argument function). -/ | elim_cons (h_v : ProgSem σ val (.data (Data.l (hd :: tl))) t_v s_v) (h_cs : ProgSem σ cs cv t_cs s_cs) (h_app₁ : AppSem cv (.data hd) cv' t₁ s₁) (h_app₂ : AppSem cv' (.data (Data.l tl)) r t₂ s₂) : - ProgSem σ (.elim val emp cs) r (t_v + t_cs + t₁ + t₂) - (max (max (max s_v s_cs) s₁) s₂) + ProgSem σ (.elim val emp cs) r (t_v + t_cs + t₁ + t₂) (s_v + s_cs + s₁ + s₂) | ifEq_then (h_x : ProgSem σ x (.data vx) t_x s_x) (h_y : ProgSem σ y (.data vx) t_y s_y) (h_then : ProgSem σ then_ r t_then s_then) : - ProgSem σ (.ifEq x y then_ else_) r - (t_x + t_y + t_then) - (max (max s_x s_y) s_then) + ProgSem σ (.ifEq x y then_ else_) r (t_x + t_y + t_then) (s_x + s_y + s_then) | ifEq_else (h_x : ProgSem σ x (.data vx) t_x s_x) (h_y : ProgSem σ y (.data vy) t_y s_y) (h_neq : vx ≠ vy) (h_else : ProgSem σ else_ r t_else s_else) : - ProgSem σ (.ifEq x y then_ else_) r - (t_x + t_y + t_else) - (max (max s_x s_y) s_else) + ProgSem σ (.ifEq x y then_ else_) r (t_x + t_y + t_else) (s_x + s_y + s_else) /-- `while_ init body`: evaluate `init` to the starting accumulator and `body` to a one-argument closure, then iterate the closure via `WhileSem` until it halts. -/ | while_ (h_init : ProgSem σ init (.data acc) t_init s_init) (h_body : ProgSem σ body bodyVal t_body s_body) (h_while : WhileSem bodyVal acc r t_w s_w) : - ProgSem σ (.while_ init body) (.data r) (t_init + t_body + t_w) - (max (max s_init s_body) s_w) + ProgSem σ (.while_ init body) (.data r) (t_init + t_body + t_w) (s_init + s_body + s_w) /-- `fn body`: evaluate to a closure capturing the current environment `σ`. The cost is the size of the resulting closure (mirroring `var`, which charges the size of the value it - produces). - TODO: We could charge only the size of the referenced variables, which would make it - more or less free to create a non-capturing closure. -/ - | fn : - ProgSem σ (.fn body) (.closure body σ) + produces). -/ + | fn : ProgSem σ (.fn body) (.closure body σ) (Value.closure body σ).size (Value.closure body σ).size /-- `app fn arg`: evaluate `fn` to a closure, evaluate `arg` to a value, then run the closure's body in the *captured* environment extended with the argument (static @@ -154,7 +159,7 @@ inductive ProgSem : (List Value) → Prog → Value → ℕ → ℕ → Prop (h_fn : ProgSem σ fn fv t_f s_f) (h_arg : ProgSem σ arg v t_a s_a) (h_app : AppSem fv v r t_b s_b) : - ProgSem σ (.app fn arg) r (t_f + t_a + t_b) (max (max s_f s_a) s_b) + ProgSem σ (.app fn arg) r (t_f + t_a + t_b) (s_f + s_a + s_b) /-- Application of a value to an argument value. `AppSem f v r t s` means that applying the closure `f` to the argument `v` yields `r` using `t` time and `s` space. Only closures can be @@ -181,6 +186,28 @@ inductive WhileSem : Value → Data → Data → ℕ → ℕ → Prop WhileSem bodyVal acc r (t_b + t_r) (max s_b s_r) end +/-- Producing a value costs at least its size, in both time and space. This holds because every +`ProgSem` derivation either reads/builds the value directly (charging its size) or returns a +value produced by a sub-derivation whose cost it includes. Provable by mutual induction over +`ProgSem`/`AppSem`/`WhileSem`. -/ +lemma ProgSem.size_le {σ : List Value} {p : Prog} {v : Value} {t s : ℕ} + (h : ProgSem σ p v t s) : v.size ≤ t ∧ v.size ≤ s := by + -- cases h with + -- | var => simp + -- | empty => simp + -- | cons h₁ h₂ => + -- constructor + -- · let r := (ProgSem.size_le h₁).left + -- let q := (ProgSem.size_le h₂).left + -- rw [Value.size_data] at r + -- rw [Value.size_data] at q + -- simp [Value.size] at * + -- grind + -- · + -- sorry + -- | _ => sorry + sorry + /-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/ def Prog.ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop := ProgSem [.data x] p (.data y) t s @@ -225,6 +252,12 @@ inductive InPlace : Prog → Prop accumulator. -/ | while_ (hinit : InPlace init) (hbody : InPlace body) : InPlace (.while_ init (.fn body)) + /-- `app` whose operator is a literal one-argument function `fn body`: this is a `let`, + binding the value of `arg` and running `body` on the spot. The abstraction is consumed + immediately, so no closure escapes. Nested applications of this form give multi-argument + `let`-chains; arbitrary arities follow by repeated use of this constructor. -/ + | app (hbody : InPlace body) (harg : InPlace arg) : + InPlace (.app (.fn body) arg) end RoseTreeMachine diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index fdaf60661..12a002b86 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -335,25 +335,26 @@ lemma singleTapeTMStep_computes exact PB.head_computes (cfgBitape_computes (h_cfg.extend ext |>.extend _)) /-- Run the step function for `steps` iterations, staying at a halting configuration. -/ -def timeBoundedSimulatorMain (tr cfg steps : PB) : PB := - PB.forLoop steps cfg (fun _ cfg => (singleTapeTMStep tr cfg).optionElim cfg (fun next => next)) +def timeBoundedSimulatorMain (tr cfg steps : ℕ) : PB := + PB.forLoop (.var steps) (.var cfg) + (fun _ cfg => (singleTapeTMStep (.var tr) cfg).optionElim cfg (fun next => next)) lemma timeBoundedSimulatorMain_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {p_tr p_cfg p_steps : PB} + {p_tr p_cfg p_steps : ℕ} {cfg : tm.Cfg} {steps : ℕ} {stateEnum : List tm.State} {symEnum : List (Option Symbol)} (h_stateEnum : ∀ q', q' ∈ stateEnum) (h_symEnum : ∀ c', c' ∈ symEnum) - (h_tr : p_tr.ComputesEnc env + (h_tr : PB.EnvEnc env p_tr (stateEnum.map (fun q' => (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))) - (h_cfg : p_cfg.ComputesEnc env cfg) - (h_steps : p_steps.ComputesEnc env steps) : + (h_cfg : PB.EnvEnc env p_cfg cfg) + (h_steps : PB.EnvEnc env p_steps steps) : (timeBoundedSimulatorMain p_tr p_cfg p_steps).ComputesEnc env ((fun c => (tm.step c).getD c)^[steps] cfg) := by have : ∀ g m (b : tm.Cfg), g^[m] b = (List.range m).foldl (fun c _ => g c) b := by @@ -374,6 +375,26 @@ lemma timeBoundedSimulatorMain_computes exact PB.optionElim_computesEnc_some (hsc ▸ hstep) (PB.computesFun₂_branch (fun ext => PB.var_computes_fresh ext _)) +set_option autoImplicit false in +lemma timeBoundedSimulatorMain_complexity : ∃ k, ∀ Symbol + [Inhabited Symbol] [Fintype Symbol] [DataEncode Symbol] + {tm : SingleTapeTM Symbol} + [DataEncode tm.State] + {p_tr p_cfg p_steps : ℕ} + {cfg : tm.Cfg} + {steps : ℕ} + {stateEnum : List tm.State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) + (h_tr : PB.EnvEnc env p_tr + (stateEnum.map (fun q' => + (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))) + (h_cfg : PB.EnvEnc env p_cfg cfg) + (h_steps : PB.EnvEnc env p_steps steps), + PB.TimeBounded env (timeBoundedSimulatorMain p_tr p_cfg p_steps) + (k * (Fintype.card Symbol) * (Fintype.card tm.State) * (steps + 1) ^ 2) := by sorry + def stringToTape (input : PB) : PB := PB.toPair input.listHeadOption (PB.toPair .empty (input.tail.listMap .some)) @@ -591,6 +612,15 @@ def timeBoundedSimulator (input : PB) := let cfg := timeBoundedSimulatorMain tr (initialConfig q₀ inputStr) steps PB.boolIte cfg.fst.isNone .none (tapeToOutput cfg.snd) +def timeBoundedSimulator' (input : PB) := + --let q₀ := input.fst + PBlet q₀ := input.fst.fst in + PBlet tr := input.fst.snd in + PBlet inputStr := input.snd.fst in + PBlet steps := input.snd.snd in + let cfg := timeBoundedSimulatorMain tr (initialConfig q₀ inputStr) steps + PB.boolIte cfg.fst.isNone .none (tapeToOutput cfg.snd) + def timeBoundedSimulatorF [Inhabited Symbol] [Fintype Symbol] (tm : SingleTapeTM Symbol) [DataEncode tm.State] (input : List Symbol) @@ -626,6 +656,25 @@ lemma timeBoundedSimulator_computes [Inhabited Symbol] [Fintype Symbol] PB.none_computes (tapeToOutput_computes (cfgBitape_computes h_main)) +lemma timeBoundedSimulator_time [Inhabited Symbol] [Fintype Symbol] + {p_input : PB} + {tm : SingleTapeTM Symbol} [DataEncode tm.State] + {input : List Symbol} + {steps : ℕ} + {stateEnum : List tm.State} + {symEnum : List (Option Symbol)} + (h_stateEnum : ∀ q', q' ∈ stateEnum) + (h_symEnum : ∀ c', c' ∈ symEnum) + (h_input : p_input.ComputesEnc env + ((tm.q₀, (stateEnum.map (fun q' => + (q', symEnum.map (fun c' : Option Symbol => (c', tm.tr q' c')))))), + input, + steps)) : + PB.OTime + (timeBoundedSimulator p_input) + (fun _ => steps * steps) := by + sorry + /-- Encode `Bool` into an alphabet of size at least 2. -/ def boolIntoFink {k} : Bool → Fin (k + 2) | true => 0 @@ -643,6 +692,27 @@ instance {k : ℕ} : DataEncode (Fin k) where encode x := DataEncode.encode x.val h_inj := by grind [DataEncode.h_inj, Function.Injective] +lemma universal_time_bounded_simulator_inner' : + ∃ overhead : ℕ, ∀ + {k₁ : ℕ} + (tm : SingleTapeTM (Fin (k₁ + 2))) + [DataEncode tm.State] + (input output : List Bool) + (steps : ℕ), + tm.OutputsWithinTime (input.map boolIntoFink) (output.map boolIntoFink) steps ↔ + ∃ s, + ComputesFunInAdditionalTimeAndSpace + timeBoundedSimulator + ((tm.q₀, encodeTMTr tm), input, steps) + (Option.some output) + -- The simulation has quadratic overhead (`steps * steps`), but it is independent + -- of the input size. + (overhead * (DataEncode.encode (encodeTMTr tm)).size * steps * steps + + overhead * (DataEncode.encode (encodeTMTr tm)).size) + s + := by + sorry + lemma universal_time_bounded_simulator_inner : ∃ overhead : ℕ, ∀ {k₁ : ℕ} @@ -652,7 +722,7 @@ lemma universal_time_bounded_simulator_inner : (steps : ℕ), tm.OutputsWithinTime (input.map boolIntoFink) (output.map boolIntoFink) steps ↔ ∃ s, - PB.ComputesInTimeAndSpace + ComputesFunInAdditionalTimeAndSpace timeBoundedSimulator ((tm.q₀, encodeTMTr tm), input, steps) (Option.some output) diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index e67462ae0..0dd3187d7 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -64,12 +64,14 @@ lemma constantEnc_computesEnc {α : Type} [DataEncode α] {a : α} : simp [ComputesEnc, constantEnc] +lemma constant_linear {α : Type} [DataEncode α] {a : α} : + Linear (constantEnc a) := by + sorry + + /-- Returns the tail of a list-valued builder (`[]` when empty). -/ def tail (x : PB) : PB := .elim x .empty (fun _hd tl => tl) -/-- Returns the head of a list-valued builder (`Data.l []` when empty). -/ -def head (x : PB) : PB := .elim x .empty (fun hd _tl => hd) - @[simp] lemma tail_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : (tail x).Computes env (.data (Data.l dx.asList.tail)) := by @@ -82,6 +84,14 @@ lemma tail_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : simpa [PB.computesFun₂, var] using var_computesFun (binds := [.data hd, .data (Data.l tl)]) (j := 1) ext +lemma tail_linear (x : PB) (h_x : Linear x) : Linear (tail x) := by + refine elim_linear h_x empty_linear ⟨?_, ?_⟩ <;> + refine ⟨1, fun env a b z t s h => ?_⟩ <;> + grind [ProgSem.var_inv h] + +/-- Returns the head of a list-valued builder (`Data.l []` when empty). -/ +def head (x : PB) : PB := .elim x .empty (fun hd _tl => hd) + @[simp] lemma head_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : Computes env (PB.head x) (.data (dx.asList.headD (Data.l []))) := by @@ -94,6 +104,11 @@ lemma head_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : simpa [PB.computesFun₂, var] using var_computesFun (binds := [.data hd, .data (Data.l tl)]) (j := 0) ext +lemma head_linear (x : PB) (h_x : Linear x) : Linear (head x) := by + refine elim_linear h_x empty_linear ⟨?_, ?_⟩ <;> + refine ⟨1, fun env a b z t s h => ?_⟩ <;> + grind [ProgSem.var_inv h] + /-- First projection (`head`). -/ def fst (x : PB) : PB := head x @@ -102,6 +117,8 @@ lemma fst_ComputesEnc {x : PB} {a : α × β} (hx : x.ComputesEnc env a) : obtain ⟨a, b⟩ := a apply PB.head_computes hx +lemma fst_linear (x : PB) (h_x : Linear x) : Linear (fst x) := head_linear x h_x + /-- Second projection (`head` of `tail`). -/ def snd (x : PB) : PB := head (PB.tail x) @@ -110,11 +127,16 @@ lemma snd_ComputesEnc {x : PB} {a : α × β} (hx : x.ComputesEnc env a) : obtain ⟨a, b⟩ := a apply PB.head_computes (PB.tail_computes hx) +lemma snd_linear (x : PB) (h_x : Linear x) : Linear (snd x) := by + apply head_linear (tail x) (tail_linear x h_x) + def none : PB := .empty lemma none_computes : none.ComputesEnc env (Option.none : Option α) := by apply empty_computes +lemma none_linear : Linear none := empty_linear + /-- `Option.some` as a singleton list. -/ def some (x : PB) : PB := cons x empty @@ -122,6 +144,9 @@ lemma some_ComputesEnc {x : PB} {a : α} (hx : x.ComputesEnc env a) : (PB.some x).ComputesEnc env (Option.some a) := by apply PB.cons_computes hx empty_computes +def some_linear (x : PB) (h_x : Linear x) : Linear (some x) := by + sorry + /-- Eliminate an `Option`: on `none` (empty) run `noneCase`, on `some v` run `someCase v`. -/ def optionElim (x noneCase : PB) (someCase : PB → PB) : PB := elim x noneCase (fun v _ => someCase v) From 11d71ed6565e1b99cde74fc5daeb11a9606538e1 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 23 Jun 2026 08:33:46 +0200 Subject: [PATCH 19/22] Complexity of elim is linear in the accessed environment. --- Cslib/Computability/Machines/RTM/Arith.lean | 17 ++ Cslib/Computability/Machines/RTM/PB.lean | 205 ++++++++++++++++-- Cslib/Computability/Machines/RTM/Prog.lean | 85 ++++++-- .../Machines/RTM/TMSimulator.lean | 3 +- 4 files changed, 279 insertions(+), 31 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Arith.lean b/Cslib/Computability/Machines/RTM/Arith.lean index 2e5ae9570..cfaad397f 100644 --- a/Cslib/Computability/Machines/RTM/Arith.lean +++ b/Cslib/Computability/Machines/RTM/Arith.lean @@ -497,6 +497,23 @@ lemma forLoop_computes {pn pinit : PB} {pf : PB → PB → PB} while_computes h_init (forLoop_loop hf n init n 0 init (by omega) (by simp)) exact snd_ComputesEnc (snd_ComputesEnc (snd_ComputesEnc hwhile)) +-- for loop complexity. If the + +lemma forLoop_complexity_constant + {vn vinit : ℕ} {pf : PB → PB → PB} + {n : ℕ} {init : α} {f : ℕ → α → α} + --(h_linear : ∃ k₁, ∀ env, TimeBounded env pf LinearFun₂ pf) + : + ∃ k, ∀ env, + (hn : PB.EnvEnc env vn n) → + (hinit : PB.EnvEnc env vinit init) → + (hf : ∀ e {pi pacc : ℕ} {i : ℕ} {a : α}, env <+: e → + PB.EnvEnc e pi i → PB.EnvEnc e pacc a → (pf (.var pi) (.var pacc)).ComputesEnc e (f i a)) → + (h_grow : ∃ c, ∀ i a, (DataEncode.encode (f i a)).size ≤ (DataEncode.encode a).size + c) → + -- TODO is that the right condition? + TimeBounded env (forLoop (.var vn) (.var vinit) pf) (k * envSize env * n * n) := by + sorry + end PB end RoseTreeMachine diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index ec505b31a..f8844bce3 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -8,6 +8,7 @@ module public import Cslib.Computability.Machines.RTM.Prog public import Cslib.Computability.Machines.RTM.DataEncode +import Mathlib.Tactic.Linarith /-! # Program builder for rose tree machines @@ -129,12 +130,28 @@ def EnvEnc {α : Type} [DataEncode α] (env : List Value) (var : ℕ) (x : α) : ------------------- Resource Consumption ------------------------- +/-- The sum of the sizes of the values in an environment. -/ @[scoped grind =] def envSize (env : List Value) : ℕ := env.map (fun x : Value => x.size) |>.sum +/-- The sum of the sizes of the variables accessed by `impl`.. This is essentially the size of the +closure, so it is implemented via that. -/ +def accessedEnvSize (impl : PB) (env : List Value) := + (Value.closure (impl env.length) env).size + +def accessedEnvSizeFun₂ (impl : PB → PB → PB) (env : List Value) (x y : Value) := + (Value.closure + (impl (.var env.length) (.var (env.length + 1)) (env.length + 2)) + (env ++ [x, y])).size + +/-- An upper bound on the runtime of the program `impl`. Note that this assumes that the program +always halts. -/ def TimeBounded (env : List Value) (impl : PB) (t : ℕ) := ∀ x t' s, ProgSem env (impl env.length) x t' s → t' ≤ t +def TimeBoundedFun₁ (env : List Value) (impl : PB → PB) (t : ℕ) := + ∀ e, env <+: e → ∀ x, TimeBounded (e ++ [x]) (impl (.var e.length)) t + def SpaceBounded (env : List Value) (impl : PB) (s : ℕ) := ∀ x t s', ProgSem env (impl env.length) x t s' → s' ≤ s @@ -152,22 +169,22 @@ def OSpaceFun₁ (impl : PB → PB) (s : List Value → ℕ) := ∃ k, ∀ env x y t s', ProgSem (env ++ [x]) (impl (.var env.length) (env.length + 1)) y t s' → s' ≤ k * (s (env ++ [x])) + k -def OTimeFun₂ (impl : PB → PB → PB) (t : List Value → ℕ) := +def OTimeFun₂ (impl : PB → PB → PB) (t : List Value → Value → Value → ℕ) := ∃ k, ∀ env x y z t' s, ProgSem (env ++ [x, y]) (impl (.var env.length) (.var (env.length + 1)) (env.length + 2)) z t' s → - t' ≤ k * (t (env ++ [x, y])) + k + t' ≤ k * (t env x y) + k -def OSpaceFun₂ (impl : PB → PB → PB) (s : List Value → ℕ) := +def OSpaceFun₂ (impl : PB → PB → PB) (s : List Value → Value → Value → ℕ) := ∃ k, ∀ env x y z t s', ProgSem (env ++ [x, y]) (impl (.var env.length) (.var (env.length + 1)) (env.length + 2)) z t s' → - s' ≤ k * (s (env ++ [x, y])) + k + s' ≤ k * (s env x y) + k -/-- The space and time complexity of `impl` is linear in the size of the environment. +/-- The space and time complexity of `impl` is linear in the size of the accessed environment. Note that this is more or less the best complexity we can have. -/ -def Linear (impl : PB) := OTime impl envSize ∧ OSpace impl envSize +def Linear (impl : PB) := OTime impl (accessedEnvSize impl) ∧ OSpace impl (accessedEnvSize impl) def LinearFun₂ (impl : PB → PB → PB) := - OTimeFun₂ impl envSize ∧ OSpaceFun₂ impl envSize + OTimeFun₂ impl (accessedEnvSizeFun₂ impl) ∧ OSpaceFun₂ impl (accessedEnvSizeFun₂ impl) --------------------- Lemmas for combinators ------------------------------- @@ -213,7 +230,21 @@ lemma var_computes_of_envEnc {α : Type} [DataEncode α] {var : ℕ} {x : α} (h intro ext exact ⟨_, _, (h ext) ▸ ProgSem.var⟩ -lemma empty_linear : Linear (PB.empty) := by sorry +lemma empty_linear : Linear (PB.empty) := by + have hcs : ∀ env, accessedEnvSize PB.empty env = 0 := fun env => by + simp only [accessedEnvSize, PB.empty, Value.size] + exact closureSize_of_noVar (fun i => by simp [Prog.hasVar]) + refine ⟨⟨2, fun env => ?_⟩, ⟨2, fun env => ?_⟩⟩ + · unfold TimeBounded + intro x t' s h + simp only [PB.empty] at h + cases h + simp [hcs] + · unfold SpaceBounded + intro x t s' h + simp only [PB.empty] at h + cases h + simp [hcs] @[simp] lemma empty_computes : Computes env empty (.data (.l [])) := by @@ -359,20 +390,116 @@ lemma elim_cons_computes {v em : PB} {cs : PB → PB → PB} rw [hmap]; exact hb exact ⟨_, _, ProgSem.elim_cons hv' ProgSem.fn (AppSem.mk ProgSem.fn) (AppSem.mk hb')⟩ +/-- Shared core for the linearity of `PB.elim`: bounds a single cost dimension (selected by the +additive projection `π`, instantiated as `fun t _ => t` for time and `fun _ s => s` for space). -/ +private lemma elim_linear_aux + {v em : PB} {cs : PB → PB → PB} {k_v k_e k_c : ℕ} + (π : ℕ → ℕ → ℕ) + (πadd : ∀ a b c d, π (a + b) (c + d) = π a c + π b d) + (πid : ∀ a, π a a = a) + (hv : ∀ env x t s, ProgSem env (v env.length) x t s + → π t s ≤ k_v * accessedEnvSize v env + k_v) + (he : ∀ env x t s, ProgSem env (em env.length) x t s + → π t s ≤ k_e * accessedEnvSize em env + k_e) + (hc : ∀ env x y z t s, ProgSem (env ++ [x, y]) + (cs (.var env.length) (.var (env.length + 1)) (env.length + 2)) z t s + → π t s ≤ k_c * accessedEnvSizeFun₂ cs env x y + k_c) + (hsize : ∀ env p out t s, ProgSem env p out t s → out.size ≤ π t s) : + ∃ K, ∀ env x t s, ProgSem env ((PB.elim v em cs) env.length) x t s + → π t s ≤ K * accessedEnvSize (PB.elim v em cs) env + K := by + refine ⟨((2+k_c)*(1+k_v) + ((2+k_c)*k_v + k_c)) + (k_v + k_e), fun env x t s h => ?_⟩ + set A := accessedEnvSize (PB.elim v em cs) env with hA + have hA_cs : A = closureSize ((PB.elim v em cs) env.length) env := by + simp only [hA, accessedEnvSize, Value.size] + have hBcs : ∀ i, (cs (PB.var env.length) (PB.var (env.length+1)) (env.length+2)).hasVar i + → ((PB.elim v em cs) env.length).hasVar i := by + intro i hi; simp only [PB.elim, Prog.hasVar]; simp [hi] + have aes_v : accessedEnvSize v env ≤ A := by + simp only [hA, accessedEnvSize, Value.size] + exact closureSize_mono env (by intro i hi; simp only [PB.elim, Prog.hasVar]; simp [hi]) + have aes_em : accessedEnvSize em env ≤ A := by + simp only [hA, accessedEnvSize, Value.size] + exact closureSize_mono env (by intro i hi; simp only [PB.elim, Prog.hasVar]; simp [hi]) + simp only [PB.elim] at h + cases h with + | elim_nil h₁ h₂ => + simp only [πadd] + have hv2 := hv env _ _ _ h₁ + have he2 := he env _ _ _ h₂ + nlinarith [hv2, he2, Nat.mul_le_mul_left k_v aes_v, Nat.mul_le_mul_left k_e aes_em, + Nat.zero_le A, Nat.zero_le k_c, Nat.zero_le k_v] + | elim_cons h_v' h_cs' h_app₁ h_app₂ => + cases h_cs' + cases h_app₁ with + | mk hb1 => + cases hb1 + cases h_app₂ with + | mk hb2 => + rename_i hd tl t_v s_v t₂ s₂ + set X := cs (PB.var env.length) (PB.var (env.length+1)) (env.length+2) with hXdef + simp only [πadd, πid] + set a := π t_v s_v with ha_def + have ha : a ≤ k_v * A + k_v := by + have h0 : a ≤ k_v * accessedEnvSize v env + k_v := hv env _ _ _ h_v' + have := Nat.mul_le_mul_left k_v aes_v; omega + have hsize_v : hd.size + (Data.l tl).size ≤ a := by + have h0 := hsize env _ _ _ _ h_v' + simp only [Value.size_data, Data.cons_size] at h0; omega + have hb : (Value.closure (Prog.fn X) env).size ≤ A := by + simp only [Value.size]; rw [hA_cs] + exact closureSize_mono env (fun i hi => hBcs i (by simpa [Prog.hasVar] using hi)) + have hc1 : (Value.closure X (env ++ [Value.data hd])).size ≤ A + a := by + simp only [Value.size, closureSize_append] + have h2 : closureSize.go X env.length [Value.data hd] ≤ hd.size := by + have := closureSize.go_le_sum X env.length [Value.data hd]; simpa using this + have h1 : closureSize X env ≤ A := by rw [hA_cs]; exact closureSize_mono env hBcs + omega + have hb2' : ProgSem (env ++ [Value.data hd, Value.data (Data.l tl)]) X x t₂ s₂ := by + have e : env ++ [Value.data hd] ++ [Value.data (Data.l tl)] + = env ++ [Value.data hd, Value.data (Data.l tl)] := by simp + rw [e] at hb2; exact hb2 + have haef : accessedEnvSizeFun₂ cs env (Value.data hd) (Value.data (Data.l tl)) + ≤ A + a := by + simp only [accessedEnvSizeFun₂, Value.size, closureSize_append] + rw [← hXdef] + have h2 : closureSize.go X env.length [Value.data hd, Value.data (Data.l tl)] + ≤ hd.size + (Data.l tl).size := by + have := closureSize.go_le_sum X env.length [Value.data hd, Value.data (Data.l tl)] + simpa using this + have h1 : closureSize X env ≤ A := by rw [hA_cs]; exact closureSize_mono env hBcs + omega + have hd2 : π t₂ s₂ ≤ k_c * (A + a) + k_c := by + have h0 : π t₂ s₂ ≤ k_c + * accessedEnvSizeFun₂ cs env (Value.data hd) (Value.data (Data.l tl)) + + k_c := hc env _ _ _ _ _ hb2' + have := Nat.mul_le_mul_left k_c haef; omega + nlinarith [ha, hb, hc1, hd2, Nat.zero_le A, Nat.zero_le k_c, Nat.zero_le k_v, + Nat.zero_le k_e] + lemma elim_linear {v em : PB} {cs : PB → PB → PB} - (h_v : Linear v) - (h_em : Linear em) - (h_cs : LinearFun₂ cs) : - Linear (PB.elim v em cs) := by - sorry + (h_v : Linear v) (h_em : Linear em) (h_cs : LinearFun₂ cs) : + Linear (PB.elim v em cs) := by + obtain ⟨⟨k_vt, hvt⟩, ⟨k_vs, hvs⟩⟩ := h_v + obtain ⟨⟨k_et, het⟩, ⟨k_es, hes⟩⟩ := h_em + obtain ⟨⟨k_ct, hct⟩, ⟨k_cs, hcs⟩⟩ := h_cs + refine ⟨?_, ?_⟩ + · exact elim_linear_aux (fun t _ => t) (fun _ _ _ _ => rfl) (fun _ => rfl) + (fun env x t s h => hvt env x t s h) (fun env x t s h => het env x t s h) + (fun env x y z t s h => hct env x y z t s h) + (fun _ _ _ _ _ h => (ProgSem.size_le h).1) + · exact elim_linear_aux (fun _ s => s) (fun _ _ _ _ => rfl) (fun _ => rfl) + (fun env x t s h => hvs env x t s h) (fun env x t s h => hes env x t s h) + (fun env x y z t s h => hcs env x y z t s h) + (fun _ _ _ _ _ h => (ProgSem.size_le h).2) + lemma elim_time {v em : PB} {cs : PB → PB → PB} - {t_v t_em t_cs : List Value → ℕ} + {t_v t_em : List Value → ℕ} {t_cs : List Value → Value → Value → ℕ} (h_v : OTime v t_v) (h_em : OTime em t_em) (h_cs : OTimeFun₂ cs t_cs) : - OTime (PB.elim v em cs) (fun env => t_v env + t_em env + t_cs env) := by sorry + OTime (PB.elim v em cs) (fun env => t_v env + t_em env) := by sorry @[simp] @@ -508,6 +635,54 @@ theorem WhileComputes.rec' {body : PB → PB} (μ : Data → ℕ) (result : Data rw [← hres] exact WhileComputes.step h hbody (ih (μ v) (hn ▸ hlt) v rfl) +/-- Core complexity lemma for `WhileSem`: if each body application on input of size `s` takes +time at most `T s` (with `T` monotone) and grows the accumulator size by at most `k`, then +there exist `n` steps such that `r.size ≤ acc.size + n * k` and the total time satisfies +`t ≤ ∑ i < n, T (acc.size + i * k) + r.size`. + +The monotonicity of `T` is needed to handle the ≤ in `h_size`: when shifting the inductive +hypothesis's sum from `v.size` to `acc.size`, we use `v.size + i * k ≤ acc.size + (i+1) * k` +together with monotonicity to bound each summand upward. -/ +lemma WhileSem.time_bound + {bodyVal : Value} {acc r : Data} {t s : ℕ} + (h : WhileSem bodyVal acc r t s) + {k : ℕ} {T : ℕ → ℕ} + (h_mono : Monotone T) + (h_time : ∀ v w t' s', AppSem bodyVal (.data v) (.data w) t' s' → t' ≤ T v.size) + (h_size : ∀ v w t' s', AppSem bodyVal (.data v) (.data w) t' s' → w.size ≤ v.size + k) : + ∃ n : ℕ, r.size ≤ acc.size + n * k ∧ + t ≤ ((List.range n).map (fun i => T (acc.size + i * k))).sum + r.size := by + sorry + +/-- Complexity of a `while_` loop whose body runs in time ≤ `c * envSize e + c` on any +environment `e`, and grows the accumulator size by at most `k` per step. + +For any outer extension `ext`, there exist a step count `n` and a time `T` such that +`T ≤ acc.size + envSize (env ++ ext) + + ∑ i < n, (c * (envSize (env ++ ext) + acc.size + i * k) + c) + r.size` +and the program evaluates to `r` in time `T`. The three additive components are: +- `acc.size`: cost of evaluating the initial variable (via `ProgSem.var`); +- `envSize (env ++ ext)`: cost of forming the body closure (closure size ≤ env size); +- the sum: accumulated body cost at each iteration (each step at size `acc.size + i * k`); +- `r.size`: the final halt check cost in `WhileSem.halt`. -/ +theorem while_complexity + {init : ℕ} {body : PB → PB} {c k : ℕ} + (h_body_time : ∀ (e : List Value) (x : Value) y t' s', + ProgSem (e ++ [x]) (body (.var e.length) (e.length + 1)) y t' s' → + t' ≤ c * envSize (e ++ [x]) + c) + (h_body_size : ∀ (e : List Value) (x : Value) y t' s', + ProgSem (e ++ [x]) (body (.var e.length) (e.length + 1)) y t' s' → + y.size ≤ x.size + k) + {acc r : Data} + (h_init : EnvEnc env init acc) + (h_loop : WhileComputes env body acc r) : + ∀ ext : List Value, ∃ n : ℕ, + ∃ T ≤ acc.size + envSize (env ++ ext) + + ((List.range n).map (fun i => c * (envSize (env ++ ext) + acc.size + i * k) + c)).sum + + r.size, + ∃ S, ProgSem (env ++ ext) + (PB.while_ (.var init) body (env.length + ext.length)) (.data r) T S := by + sorry ------------------- Resource Consumption ------------------------- -- /-- Resource-erased relational semantics of a program builder. -/ diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index a662bc302..87993f5bd 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -101,9 +101,72 @@ mutual | .closure p env => closureSize p env end +@[simp, scoped grind =] +lemma closureSize_of_noVar {body : Prog} {env : List Value} (h : ∀ i, ¬body.hasVar i) : + closureSize body env = 0 := by + have (depth : ℕ) : closureSize.go body depth env = 0 := by + induction env generalizing depth with + | nil => simp [closureSize.go] + | cons hd tl ih => simp [closureSize.go, h depth, ih] + simp [closureSize, this] + @[simp, scoped grind =] lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size] +/-- Splitting the environment of a closure size computation across an append. -/ +lemma closureSize.go_append (body : Prog) (depth : ℕ) (l1 l2 : List Value) : + closureSize.go body depth (l1 ++ l2) + = closureSize.go body depth l1 + closureSize.go body (depth + l1.length) l2 := by + induction l1 generalizing depth with + | nil => simp [closureSize.go] + | cons hd tl ih => + have he : depth + 1 + tl.length = depth + (tl.length + 1) := by omega + simp only [List.cons_append, closureSize.go, List.length_cons, ih (depth + 1), he] + omega + +/-- The closure size over an appended environment splits into the size over the prefix plus the +contribution of the suffix (counted starting at depth `l1.length`). -/ +lemma closureSize_append (body : Prog) (l1 l2 : List Value) : + closureSize body (l1 ++ l2) + = closureSize body l1 + closureSize.go body l1.length l2 := by + simp only [closureSize, closureSize.go_append, Nat.zero_add] + +/-- `closureSize.go` is monotone in the set of accessed variables. -/ +lemma closureSize.go_mono {body1 body2 : Prog} (env : List Value) + (h : ∀ i, body1.hasVar i → body2.hasVar i) (depth : ℕ) : + closureSize.go body1 depth env ≤ closureSize.go body2 depth env := by + induction env generalizing depth with + | nil => simp [closureSize.go] + | cons hd tl ih => + simp only [closureSize.go] + have hb : (if body1.hasVar depth then hd.size else 0) + ≤ (if body2.hasVar depth then hd.size else 0) := by + by_cases hv : body1.hasVar depth + · simp [hv, h depth hv] + · simp [hv] + have := ih (depth + 1) + omega + +/-- If every variable accessed by `body1` is also accessed by `body2`, then `body1` has a smaller +closure size over any environment. -/ +lemma closureSize_mono {body1 body2 : Prog} (env : List Value) + (h : ∀ i, body1.hasVar i → body2.hasVar i) : + closureSize body1 env ≤ closureSize body2 env := by + have := closureSize.go_mono env h 0 + simpa only [closureSize] using this + +/-- The closure size is bounded by the total size of the environment. -/ +lemma closureSize.go_le_sum (body : Prog) (depth : ℕ) (env : List Value) : + closureSize.go body depth env ≤ (env.map Value.size).sum := by + induction env generalizing depth with + | nil => simp [closureSize.go] + | cons hd tl ih => + simp only [closureSize.go, List.map_cons, List.sum_cons] + have h1 := ih (depth + 1) + have h2 : (if body.hasVar depth then hd.size else 0) ≤ hd.size := by + by_cases hv : body.hasVar depth <;> simp [hv] + omega + mutual /-- Semantics of `Prog` including time and space resource bounds. `ProgSem σ p x t s` means that on environment `σ`, the program `p` evaluates to the value @@ -192,21 +255,13 @@ value produced by a sub-derivation whose cost it includes. Provable by mutual in `ProgSem`/`AppSem`/`WhileSem`. -/ lemma ProgSem.size_le {σ : List Value} {p : Prog} {v : Value} {t s : ℕ} (h : ProgSem σ p v t s) : v.size ≤ t ∧ v.size ≤ s := by - -- cases h with - -- | var => simp - -- | empty => simp - -- | cons h₁ h₂ => - -- constructor - -- · let r := (ProgSem.size_le h₁).left - -- let q := (ProgSem.size_le h₂).left - -- rw [Value.size_data] at r - -- rw [Value.size_data] at q - -- simp [Value.size] at * - -- grind - -- · - -- sorry - -- | _ => sorry - sorry + induction h using ProgSem.rec + (motive_2 := fun _ _ r t s _ => r.size ≤ t ∧ r.size ≤ s) + (motive_3 := fun _ _ r t s _ => (Value.data r).size ≤ t ∧ (Value.data r).size ≤ s) with + | empty => exact ⟨by simp, by simp⟩ + | var | cons | elim_nil | elim_cons | ifEq_then | ifEq_else + | while_ | fn | app | mk | halt | step + => grind [Value.size_data, Data.cons_size, Data.asList_l] /-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/ def Prog.ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop := diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 12a002b86..19436093a 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -393,7 +393,8 @@ lemma timeBoundedSimulatorMain_complexity : ∃ k, ∀ Symbol (h_cfg : PB.EnvEnc env p_cfg cfg) (h_steps : PB.EnvEnc env p_steps steps), PB.TimeBounded env (timeBoundedSimulatorMain p_tr p_cfg p_steps) - (k * (Fintype.card Symbol) * (Fintype.card tm.State) * (steps + 1) ^ 2) := by sorry + (k * (DataEncode.encode cfg).size * + (Fintype.card Symbol) * (Fintype.card tm.State) * (steps + 1) ^ 2) := by sorry def stringToTape (input : PB) : PB := PB.toPair input.listHeadOption (PB.toPair .empty (input.tail.listMap .some)) From e4a603d1ab387c1a3c95a70e757684ef39073281 Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 23 Jun 2026 20:18:33 +0200 Subject: [PATCH 20/22] var is linear. --- Cslib/Computability/Machines/RTM/PB.lean | 10 +++++++++- Cslib/Computability/Machines/RTM/Prog.lean | 13 +++++++++++++ Cslib/Computability/Machines/RTM/Tools.lean | 14 ++++++++++---- 3 files changed, 32 insertions(+), 5 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index f8844bce3..f09ffde97 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -297,7 +297,15 @@ lemma ProgSem.var_inv {σ : List Value} {i : ℕ} {v : Value} {t s : ℕ} cases h exact ⟨rfl, rfl, rfl⟩ -lemma var_linear {i : ℕ} : Linear (PB.var i) := by sorry +lemma var_linear {i : ℕ} : Linear (PB.var i) := by + constructor <;> + · use 2 + intro env x t s h + cases h + simp only [accessedEnvSize, var, Value.size, closureSize_of_var] + cases env[i]? with + | none => simp + | some v => grind /-- The code in `body` computes a function of two arguments `x`, `y` and returns `out`. -/ def computesFun₂ (env : List Value) (x y : Value) (body : PB → PB → PB) (out : Value) : Prop := diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index 87993f5bd..c90c60414 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -110,6 +110,19 @@ lemma closureSize_of_noVar {body : Prog} {env : List Value} (h : ∀ i, ¬body.h | cons hd tl ih => simp [closureSize.go, h depth, ih] simp [closureSize, this] +@[simp, scoped grind =] +lemma closureSize_of_var {env : List Value} : + closureSize (.var i) env = (env[i]?.map fun v => v.size).getD 0 := by + unfold closureSize + have (d : ℕ) : closureSize.go (.var i) d env = + if h : d ≤ i ∧ i - d < env.length then (env[i - d]'(by grind)).size else 0 := by + induction env generalizing d with + | nil => simp [closureSize.go] + | cons hd tl ih => + grind [closureSize.go, List.length_cons, Prog.hasVar] + grind + + @[simp, scoped grind =] lemma Value.size_data {d : Data} : (Value.data d).size = d.size := by simp [Value.size] diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index 0dd3187d7..b0c70433d 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -86,8 +86,11 @@ lemma tail_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : lemma tail_linear (x : PB) (h_x : Linear x) : Linear (tail x) := by refine elim_linear h_x empty_linear ⟨?_, ?_⟩ <;> - refine ⟨1, fun env a b z t s h => ?_⟩ <;> - grind [ProgSem.var_inv h] + · refine ⟨1, fun env a b z t s h => ?_⟩ + obtain ⟨hz, ht, hs⟩ := ProgSem.var_inv h; subst hz + have hlt : env.length + 1 < (env ++ [a, b]).length := by simp + simp only [accessedEnvSizeFun₂, var, Value.size, closureSize_var, hlt, if_true] + omega /-- Returns the head of a list-valued builder (`Data.l []` when empty). -/ def head (x : PB) : PB := .elim x .empty (fun hd _tl => hd) @@ -106,8 +109,11 @@ lemma head_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : lemma head_linear (x : PB) (h_x : Linear x) : Linear (head x) := by refine elim_linear h_x empty_linear ⟨?_, ?_⟩ <;> - refine ⟨1, fun env a b z t s h => ?_⟩ <;> - grind [ProgSem.var_inv h] + · refine ⟨1, fun env a b z t s h => ?_⟩ + obtain ⟨hz, ht, hs⟩ := ProgSem.var_inv h; subst hz + have hlt : env.length < (env ++ [a, b]).length := by simp + simp only [accessedEnvSizeFun₂, var, Value.size, closureSize_var, hlt, if_true] + omega /-- First projection (`head`). -/ def fst (x : PB) : PB := head x From 1cec6639aed536cbda8bca3bd7d814f0d547f21e Mon Sep 17 00:00:00 2001 From: crei Date: Tue, 23 Jun 2026 20:32:11 +0200 Subject: [PATCH 21/22] fix imports. --- Cslib/Computability/Machines/RTM/Prog.lean | 1 + .../Computability/Machines/RTM/TMSimulator.lean | 16 +++++++++------- Cslib/Computability/Machines/RTM/Tools.lean | 14 +++++--------- 3 files changed, 15 insertions(+), 16 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index c90c60414..0476541e0 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -96,6 +96,7 @@ mutual /-- The size of a `Value`. The size of data is the length of its encoding and the size of a closure is the sum of the sizes of the referenced variables. -/ + @[simp] def Value.size : Value → ℕ | .data d => d.size | .closure p env => closureSize p env diff --git a/Cslib/Computability/Machines/RTM/TMSimulator.lean b/Cslib/Computability/Machines/RTM/TMSimulator.lean index 19436093a..86c43f4d8 100644 --- a/Cslib/Computability/Machines/RTM/TMSimulator.lean +++ b/Cslib/Computability/Machines/RTM/TMSimulator.lean @@ -8,7 +8,7 @@ module public import Cslib.Computability.Machines.RTM.Tools public import Cslib.Computability.Machines.RTM.Arith -public import Cslib.Computability.Machines.SingleTapeTuring.Basic +public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic public import Mathlib.Data.List.ReduceOption /-! # Universal Turing-machine simulator as a rose tree machine @@ -46,23 +46,25 @@ namespace RoseTreeMachine -- then, we show that the time and space of each iteration is linear in its input. -- so overall, t iterations are computed in O(t^2) time and O(t) space. +open Cslib.Turing + variable [DataEncode Symbol] variable {env : List Value} -public instance : DataEncode (Turing.StackTape Symbol) where +public instance : DataEncode (StackTape Symbol) where encode t := DataEncode.encode t.toList h_inj := by intro ⟨l₁, h₁⟩ ⟨l₂, h₂⟩ h grind [DataEncode.h_inj h] -public instance : DataEncode (Turing.BiTape Symbol) where +public instance : DataEncode (Cslib.Turing.BiTape Symbol) where encode t := DataEncode.encode (t.head, t.left, t.right) h_inj := by intro ⟨h₁, l₁, r₁⟩ ⟨h₂, l₂, r₂⟩ h grind [DataEncode.h_inj h] -lemma encode_biTape (t : Turing.BiTape Symbol) : +lemma encode_biTape (t : BiTape Symbol) : DataEncode.encode t = DataEncode.encode (t.head, t.left, t.right) := by simp [DataEncode.encode] @@ -213,7 +215,7 @@ lemma bitapeOptionMove_computes {p_t p_dir : PB} /-- Encoding of a `SingleTapeTM`, assuming the state set and alphabet are encodable. -/ instance [Inhabited Symbol] [Fintype Symbol] (tm : SingleTapeTM Symbol) [DataEncode tm.State] : - DataEncode (Turing.SingleTapeTM.Cfg tm) where + DataEncode (SingleTapeTM.Cfg tm) where encode cfg := DataEncode.encode (cfg.state, cfg.BiTape) h_inj := by intro ⟨s₁, t₁⟩ ⟨s₂, t₂⟩ h @@ -225,14 +227,14 @@ def cfgBitape (cfg : PB) : PB := cfg.snd lemma cfgState_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} + {p : PB} {cfg : SingleTapeTM.Cfg tm} (h : p.ComputesEnc env cfg) : (cfgState p).ComputesEnc env cfg.state := PB.fst_ComputesEnc (a := (cfg.state, cfg.BiTape)) h lemma cfgBitape_computes [Inhabited Symbol] [Fintype Symbol] {tm : SingleTapeTM Symbol} [DataEncode tm.State] - {p : PB} {cfg : Turing.SingleTapeTM.Cfg tm} + {p : PB} {cfg : SingleTapeTM.Cfg tm} (h : p.ComputesEnc env cfg) : (cfgBitape p).ComputesEnc env cfg.BiTape := PB.snd_ComputesEnc (a := (cfg.state, cfg.BiTape)) h diff --git a/Cslib/Computability/Machines/RTM/Tools.lean b/Cslib/Computability/Machines/RTM/Tools.lean index b0c70433d..a5ca009fe 100644 --- a/Cslib/Computability/Machines/RTM/Tools.lean +++ b/Cslib/Computability/Machines/RTM/Tools.lean @@ -87,10 +87,8 @@ lemma tail_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : lemma tail_linear (x : PB) (h_x : Linear x) : Linear (tail x) := by refine elim_linear h_x empty_linear ⟨?_, ?_⟩ <;> · refine ⟨1, fun env a b z t s h => ?_⟩ - obtain ⟨hz, ht, hs⟩ := ProgSem.var_inv h; subst hz - have hlt : env.length + 1 < (env ++ [a, b]).length := by simp - simp only [accessedEnvSizeFun₂, var, Value.size, closureSize_var, hlt, if_true] - omega + obtain ⟨rfl, ht, hs⟩ := ProgSem.var_inv h + simp [accessedEnvSizeFun₂, var, ht, hs] /-- Returns the head of a list-valued builder (`Data.l []` when empty). -/ def head (x : PB) : PB := .elim x .empty (fun hd _tl => hd) @@ -110,10 +108,8 @@ lemma head_computes {x : PB} {dx : Data} (hx : x.Computes env (.data dx)) : lemma head_linear (x : PB) (h_x : Linear x) : Linear (head x) := by refine elim_linear h_x empty_linear ⟨?_, ?_⟩ <;> · refine ⟨1, fun env a b z t s h => ?_⟩ - obtain ⟨hz, ht, hs⟩ := ProgSem.var_inv h; subst hz - have hlt : env.length < (env ++ [a, b]).length := by simp - simp only [accessedEnvSizeFun₂, var, Value.size, closureSize_var, hlt, if_true] - omega + obtain ⟨rfl, ht, hs⟩ := ProgSem.var_inv h + simp [accessedEnvSizeFun₂, var, ht, hs] /-- First projection (`head`). -/ def fst (x : PB) : PB := head x @@ -150,7 +146,7 @@ lemma some_ComputesEnc {x : PB} {a : α} (hx : x.ComputesEnc env a) : (PB.some x).ComputesEnc env (Option.some a) := by apply PB.cons_computes hx empty_computes -def some_linear (x : PB) (h_x : Linear x) : Linear (some x) := by +lemma some_linear (x : PB) (h_x : Linear x) : Linear (some x) := by sorry /-- Eliminate an `Option`: on `none` (empty) run `noneCase`, on `some v` run `someCase v`. -/ From 834c364a8bf529b824a120c9d692173fb5354104 Mon Sep 17 00:00:00 2001 From: crei Date: Wed, 24 Jun 2026 13:53:32 +0200 Subject: [PATCH 22/22] Progress on while runtime. --- Cslib/Computability/Machines/RTM/Arith.lean | 4 +- Cslib/Computability/Machines/RTM/PB.lean | 366 +++++++++++++++++--- Cslib/Computability/Machines/RTM/Prog.lean | 53 +++ 3 files changed, 373 insertions(+), 50 deletions(-) diff --git a/Cslib/Computability/Machines/RTM/Arith.lean b/Cslib/Computability/Machines/RTM/Arith.lean index cfaad397f..ad23f22db 100644 --- a/Cslib/Computability/Machines/RTM/Arith.lean +++ b/Cslib/Computability/Machines/RTM/Arith.lean @@ -497,7 +497,9 @@ lemma forLoop_computes {pn pinit : PB} {pf : PB → PB → PB} while_computes h_init (forLoop_loop hf n init n 0 init (by omega) (by simp)) exact snd_ComputesEnc (snd_ComputesEnc (snd_ComputesEnc hwhile)) --- for loop complexity. If the +-- TODO continue here: IF the body function is Linear (in the new sense) +-- and the output grows at most by an additive constant, +--- then... lemma forLoop_complexity_constant {vn vinit : ℕ} {pf : PB → PB → PB} diff --git a/Cslib/Computability/Machines/RTM/PB.lean b/Cslib/Computability/Machines/RTM/PB.lean index f09ffde97..c2afb1696 100644 --- a/Cslib/Computability/Machines/RTM/PB.lean +++ b/Cslib/Computability/Machines/RTM/PB.lean @@ -9,6 +9,7 @@ module public import Cslib.Computability.Machines.RTM.Prog public import Cslib.Computability.Machines.RTM.DataEncode import Mathlib.Tactic.Linarith +import Mathlib.Algebra.BigOperators.Group.List.Defs /-! # Program builder for rose tree machines @@ -139,6 +140,9 @@ closure, so it is implemented via that. -/ def accessedEnvSize (impl : PB) (env : List Value) := (Value.closure (impl env.length) env).size +def accessedEnvSizeFun₁ (impl : PB → PB) (env : List Value) (x : Value) := + (Value.closure (impl (.var env.length) (env.length + 1)) (env ++ [x])).size + def accessedEnvSizeFun₂ (impl : PB → PB → PB) (env : List Value) (x y : Value) := (Value.closure (impl (.var env.length) (.var (env.length + 1)) (env.length + 2)) @@ -161,13 +165,13 @@ def OTime (impl : PB) (t : List Value → ℕ) := def OSpace (impl : PB) (s : List Value → ℕ) := ∃ k, ∀ env, SpaceBounded env impl (k * (s env) + k) -def OTimeFun₁ (impl : PB → PB) (t : List Value → ℕ) := +def OTimeFun₁ (impl : PB → PB) (t : List Value → Value → ℕ) := ∃ k, ∀ env x y t' s, ProgSem (env ++ [x]) (impl (.var env.length) (env.length + 1)) y t' s → - t' ≤ k * (t (env ++ [x])) + k + t' ≤ k * (t env x) + k -def OSpaceFun₁ (impl : PB → PB) (s : List Value → ℕ) := +def OSpaceFun₁ (impl : PB → PB) (s : List Value → Value → ℕ) := ∃ k, ∀ env x y t s', ProgSem (env ++ [x]) (impl (.var env.length) (env.length + 1)) y t s' → - s' ≤ k * (s (env ++ [x])) + k + s' ≤ k * (s env x) + k def OTimeFun₂ (impl : PB → PB → PB) (t : List Value → Value → Value → ℕ) := ∃ k, ∀ env x y z t' s, ProgSem (env ++ [x, y]) @@ -183,9 +187,17 @@ def OSpaceFun₂ (impl : PB → PB → PB) (s : List Value → Value → Value Note that this is more or less the best complexity we can have. -/ def Linear (impl : PB) := OTime impl (accessedEnvSize impl) ∧ OSpace impl (accessedEnvSize impl) +def LinearFun₁ (impl : PB → PB) := + OTimeFun₁ impl (accessedEnvSizeFun₁ impl) ∧ OSpaceFun₁ impl (accessedEnvSizeFun₁ impl) + def LinearFun₂ (impl : PB → PB → PB) := OTimeFun₂ impl (accessedEnvSizeFun₂ impl) ∧ OSpaceFun₂ impl (accessedEnvSizeFun₂ impl) +def AdditiveGrowthFun₁ (impl : PB → PB) : Prop := + ∃ k, ∀ e x y t' s', + ProgSem (e ++ [x]) (impl (.var e.length) (e.length + 1)) y t' s' → + y.size ≤ x.size + k + --------------------- Lemmas for combinators ------------------------------- /-- Var-lookup: `PB.var i` reads the `i`-th entry of the environment. -/ @@ -643,54 +655,310 @@ theorem WhileComputes.rec' {body : PB → PB} (μ : Data → ℕ) (result : Data rw [← hres] exact WhileComputes.step h hbody (ih (μ v) (hn ▸ hlt) v rfl) -/-- Core complexity lemma for `WhileSem`: if each body application on input of size `s` takes -time at most `T s` (with `T` monotone) and grows the accumulator size by at most `k`, then -there exist `n` steps such that `r.size ≤ acc.size + n * k` and the total time satisfies -`t ≤ ∑ i < n, T (acc.size + i * k) + r.size`. - -The monotonicity of `T` is needed to handle the ≤ in `h_size`: when shifting the inductive -hypothesis's sum from `v.size` to `acc.size`, we use `v.size + i * k ≤ acc.size + (i+1) * k` -together with monotonicity to bound each summand upward. -/ -lemma WhileSem.time_bound - {bodyVal : Value} {acc r : Data} {t s : ℕ} - (h : WhileSem bodyVal acc r t s) - {k : ℕ} {T : ℕ → ℕ} - (h_mono : Monotone T) - (h_time : ∀ v w t' s', AppSem bodyVal (.data v) (.data w) t' s' → t' ≤ T v.size) - (h_size : ∀ v w t' s', AppSem bodyVal (.data v) (.data w) t' s' → w.size ≤ v.size + k) : - ∃ n : ℕ, r.size ≤ acc.size + n * k ∧ - t ≤ ((List.range n).map (fun i => T (acc.size + i * k))).sum + r.size := by +/-- Resource-erased iteration of a `while_` loop body, indexed by the exact number of iterations. +`WhileIterates env body acc r n` says that, starting from accumulator `acc`, the loop performs +exactly `n` body steps and halts with result `r`. This exposes the iteration count `n` (which is +left existential in `WhileComputes`), making it available as a meaningful parameter in complexity +statements: `r` is the result of iterating the body `n` times from `acc`. -/ +inductive WhileIterates (env : List Value) (body : PB → PB) : Data → Data → ℕ → Prop + | halt {acc : Data} + (h_stop : acc.asList.head?.getD (Data.l []) = Data.l []) : + WhileIterates env body acc acc 0 + | step {acc v r : Data} {n : ℕ} + (h_cont : acc.asList.head?.getD (Data.l []) ≠ Data.l []) + (h_body : computesFun₁ env (.data acc) body (.data v)) + (h_rest : WhileIterates env body v r n) : + WhileIterates env body acc r (n + 1) + +/-- Every `WhileComputes` run has a well-defined iteration count: it iterates the body some +number `n` of times. This is the translation from the existential reachability relation +`WhileComputes` to the iteration-counted `WhileIterates`. -/ +lemma WhileComputes.exists_iterates {body : PB → PB} {acc r : Data} + (h : WhileComputes env body acc r) : + ∃ n : ℕ, WhileIterates env body acc r n := by sorry -/-- Complexity of a `while_` loop whose body runs in time ≤ `c * envSize e + c` on any -environment `e`, and grows the accumulator size by at most `k` per step. - -For any outer extension `ext`, there exist a step count `n` and a time `T` such that -`T ≤ acc.size + envSize (env ++ ext) + - ∑ i < n, (c * (envSize (env ++ ext) + acc.size + i * k) + c) + r.size` -and the program evaluates to `r` in time `T`. The three additive components are: -- `acc.size`: cost of evaluating the initial variable (via `ProgSem.var`); -- `envSize (env ++ ext)`: cost of forming the body closure (closure size ≤ env size); -- the sum: accumulated body cost at each iteration (each step at size `acc.size + i * k`); -- `r.size`: the final halt check cost in `WhileSem.halt`. -/ -theorem while_complexity - {init : ℕ} {body : PB → PB} {c k : ℕ} - (h_body_time : ∀ (e : List Value) (x : Value) y t' s', - ProgSem (e ++ [x]) (body (.var e.length) (e.length + 1)) y t' s' → - t' ≤ c * envSize (e ++ [x]) + c) - (h_body_size : ∀ (e : List Value) (x : Value) y t' s', - ProgSem (e ++ [x]) (body (.var e.length) (e.length + 1)) y t' s' → - y.size ≤ x.size + k) - {acc r : Data} - (h_init : EnvEnc env init acc) - (h_loop : WhileComputes env body acc r) : - ∀ ext : List Value, ∃ n : ℕ, - ∃ T ≤ acc.size + envSize (env ++ ext) + - ((List.range n).map (fun i => c * (envSize (env ++ ext) + acc.size + i * k) + c)).sum + - r.size, - ∃ S, ProgSem (env ++ ext) - (PB.while_ (.var init) body (env.length + ext.length)) (.data r) T S := by +/-- An iteration-counted run is in particular a `WhileComputes` run (forgetting the count). -/ +lemma WhileIterates.toWhileComputes {body : PB → PB} {acc r : Data} {n : ℕ} + (h : WhileIterates env body acc r n) : + WhileComputes env body acc r := by sorry + +/-- After `n` iterations of a body that grows the accumulator size by at most `k` per step, the +result size has grown by at most `n * k`. This is the solved size recurrence `s_n ≤ s_0 + n * k` +for the `a = 1` regime. -/ +lemma WhileIterates.size_le + {body : PB → PB} + (h_additive : AdditiveGrowthFun₁ body) : + ∃ k, ∀ env acc r n, WhileIterates env body acc r n → r.size ≤ acc.size + n * k := by + obtain ⟨k, hk⟩ := h_additive + refine ⟨k, ?_⟩ + intro env acc r n h + induction h with + | halt => simp + | @step acc v r n h_cont h_body h_rest ih => + obtain ⟨t, s, hp⟩ := h_body [] + simp only [List.append_nil, Nat.add_zero] at hp + have hv : v.size ≤ acc.size + k := by + have := hk env (.data acc) (.data v) t s hp + simpa using this + calc r.size ≤ v.size + n * k := ih + _ ≤ (acc.size + k) + n * k := Nat.add_le_add_right hv _ + _ = acc.size + (n + 1) * k := by rw [add_one_mul]; omega + +/-- The accessed-environment size when the argument is `x` is bounded by the closure size over `σ` +alone (the `x`-independent part) plus `x.size`: the only `x`-dependent contribution is the captured +argument slot, whose size is at most `x.size`. Holds for any `body`, `σ`, `x`. -/ +lemma accessedEnvSizeFun₁_le_closure_add (body : PB → PB) (σ : List Value) (x : Value) : + accessedEnvSizeFun₁ body σ x + ≤ (Value.closure (body (.var σ.length) (σ.length + 1)) σ).size + x.size := by + simp only [accessedEnvSizeFun₁, Value.size, closureSize_append] + have hgo := closureSize.go_le_sum (body (.var σ.length) (σ.length + 1)) σ.length [x] + simp only [List.map_cons, List.map_nil, List.sum_cons, List.sum_nil, Nat.add_zero] at hgo + exact Nat.add_le_add_left hgo _ + +/-- The loop-body closure captured over `σ` alone has size at most `accessedEnvSizeFun₁ body σ x`, +the size of the same closure over `σ` extended with the argument `x`: appending the argument can +only add to the closure size. Holds for any `body`, `σ`, `x` (no semantic assumptions). -/ +@[grind .] +lemma accessedEnvSizeFun₁_closure_le (body : PB → PB) (σ : List Value) (x : Value) : + (Value.closure (body (.var σ.length) (σ.length + 1)) σ).size + ≤ accessedEnvSizeFun₁ body σ x := by + simp [accessedEnvSizeFun₁, Value.size, closureSize_append] + +/-- The accessed-environment size of a one-argument body is monotone in (an additive constant of) +the argument: replacing the argument `y` by `x` adds at most `x.size`, because the only +`x`-dependent contribution to the closure size is the captured argument slot, whose size is +`≤ x.size`. This is the `accessedEnvSize`-native splitting lemma that bounds the per-iteration +measure on `vᵢ` by the measure on the initial accumulator plus `vᵢ.size`. -/ +lemma accessedEnvSizeFun₁_mono_arg (body : PB → PB) (σ : List Value) (x y : Value) : + accessedEnvSizeFun₁ body σ x ≤ accessedEnvSizeFun₁ body σ y + x.size := + le_trans (accessedEnvSizeFun₁_le_closure_add body σ x) + (Nat.add_le_add_right (accessedEnvSizeFun₁_closure_le body σ y) _) + +/-- The affine per-iteration cost function is monotone in the accumulator size. -/ +lemma monotone_affine (c C : ℕ) : Monotone (fun m => c * (C + m) + c) := by + intro a b hab + exact Nat.add_le_add_right (Nat.mul_le_mul_left _ (Nat.add_le_add_left hab _)) c + +/-- Summation collapse for the `a = 1` regime: a sum of `n` affine terms whose argument grows by +`k` each step is bounded by `n` times the largest term, yielding the `O(n · final_size)` shape. -/ +lemma sum_range_affine_le (c M k n : ℕ) : + ((List.range n).map (fun i => c * (M + i * k) + c)).sum ≤ n * (c * (M + n * k) + c) := by + -- TODO should be provable through + -- calc + -- ((List.range n).map (fun i => c * (M + i * k) + c)).sum + -- ≤ ((List.range n).map (fun _ => c * (M + n * k) + c)).sum := by sorry + -- _ = n * (c * (M + n * k) + c) := by exact List.sum_eq_card_nsmul _ (c * (M + n * k) + c) (by simp) + + induction n with + | zero => simp + | succ n ih => + have hT : c * (M + n * k) + c ≤ c * (M + (n + 1) * k) + c := by + have hk : n * k ≤ (n + 1) * k := Nat.mul_le_mul_right _ (Nat.le_succ n) + exact Nat.add_le_add_right (Nat.mul_le_mul_left _ (Nat.add_le_add_left hk _)) c + have hS : ((List.range n).map (fun i => c * (M + i * k) + c)).sum + ≤ n * (c * (M + (n + 1) * k) + c) := le_trans ih (Nat.mul_le_mul_left _ hT) + rw [List.range_succ, List.map_append, List.sum_append] + simp only [List.map_cons, List.map_nil, List.sum_cons, List.sum_nil, Nat.add_zero] + calc ((List.range n).map (fun i => c * (M + i * k) + c)).sum + (c * (M + n * k) + c) + ≤ n * (c * (M + (n + 1) * k) + c) + (c * (M + (n + 1) * k) + c) := Nat.add_le_add hS hT + _ = (n + 1) * (c * (M + (n + 1) * k) + c) := by + rw [add_one_mul n (c * (M + (n + 1) * k) + c)] + +/-- Transports the linear *time* bound on `body` to the application of the captured `while_` body +closure: applying it to an accumulator `v` runs in time at most +`c * accessedEnvSizeFun₁ body σ v + c`, straight from `OTimeFun₁` (via `AppSem.mk` inversion). The +split into a σ-fixed part plus the argument size is handled by `accessedEnvSizeFun₁_mono_arg`. -/ +lemma bodyClosure_app_time {body : PB → PB} (h : LinearFun₁ body) (σ : List Value) : + ∃ c : ℕ, ∀ (v w : Data) (t' s' : ℕ), + AppSem (.closure (body (.var σ.length) (σ.length + 1)) σ) (.data v) (.data w) t' s' → + t' ≤ c * accessedEnvSizeFun₁ body σ (.data v) + c := by + obtain ⟨c, hc⟩ := h.1 + refine ⟨c, ?_⟩ + intro v w t' s' happ + cases happ with + | mk hp => exact hc σ (.data v) (.data w) t' s' hp + +/-- Transports the linear *space* bound on `body` to the application of the captured `while_` body +closure. -/ +lemma bodyClosure_app_space {body : PB → PB} (h : LinearFun₁ body) (σ : List Value) : + ∃ c : ℕ, ∀ (v w : Data) (t' s' : ℕ), + AppSem (.closure (body (.var σ.length) (σ.length + 1)) σ) (.data v) (.data w) t' s' → + s' ≤ c * accessedEnvSizeFun₁ body σ (.data v) + c := by + obtain ⟨c, hc⟩ := h.2 + refine ⟨c, ?_⟩ + intro v w t' s' happ + cases happ with + | mk hp => exact hc σ (.data v) (.data w) t' s' hp + +/-- Internal inductive core for `WhileIterates.time_bound_of_linear_body`: bounds the cost of the +`WhileSem` loop iteration itself (excluding the `init` read and the `fn`-closure build). Proven by +induction on `WhileIterates` in lockstep with `WhileSem`, collapsing the per-iteration affine costs +(`bodyClosure_app_time` + `accessedEnvSizeFun₁_mono_arg`, monotone via `monotone_affine`) with +`sum_range_affine_le`, and folding the halting `acc.size`/`r.size` cost via `WhileIterates.size_le`. +The trailing `(M + n)` term is the `WhileSem.halt` cost. -/ +lemma WhileIterates.whileSem_time_le {body : PB → PB} + (h_body : LinearFun₁ body) (h_growth : AdditiveGrowthFun₁ body) : + ∃ C, ∀ (env : List Value) (acc r : Data) (n : ℕ) {t s : ℕ}, + WhileIterates env body acc r n → + WhileSem (.closure (body (.var env.length) (env.length + 1)) env) acc r t s → + t ≤ C * (n * (accessedEnvSizeFun₁ body env (.data acc) + acc.size + n)) + + (accessedEnvSizeFun₁ body env (.data acc) + acc.size + n) := by + obtain ⟨c, hc⟩ := h_body.1 + obtain ⟨k, hgrow⟩ := h_growth + refine ⟨c * k + 2 * c + k + 1, ?_⟩ + intro env + -- The σ-only part of the closure size (independent of the accumulator). + set base := (Value.closure (body (.var env.length) (env.length + 1)) env).size with hbase + -- Core max-term bound: each of the `m` iterations costs at most the largest per-iteration term + -- `c * (base + acc.size + m * k) + c`, plus the final accumulator size `acc.size + m * k`. + have core : ∀ (acc r : Data) (m : ℕ) (t s : ℕ), + WhileIterates env body acc r m → + WhileSem (.closure (body (.var env.length) (env.length + 1)) env) acc r t s → + t ≤ m * (c * (base + acc.size + m * k) + c) + (acc.size + m * k) := by + intro acc r m t s h_iter + induction h_iter generalizing t s with + | @halt acc h_stop => + intro h_sem + cases h_sem with + | halt _ => simp + | step h_cont _ _ => exact absurd h_stop h_cont + | @step acc v r n h_cont h_body' h_rest ih => + intro h_sem + cases h_sem with + | halt h_stop => exact absurd h_stop h_cont + | step h_cont' h_app h_rest' => + rename_i vv tb sb tr sr + -- The first body step `acc → vv`; align `vv = v` via value-determinism. + obtain ⟨tb', sb', hpb⟩ := h_body' [] + simp only [List.append_nil, Nat.add_zero] at hpb + cases h_app with + | mk hpa => + have hvveq : Value.data v = Value.data vv := ProgSem.value_det hpb _ _ _ hpa + obtain rfl : v = vv := by injection hvveq + -- The largest per-iteration term for the `n+1`-iteration run. + set T := c * (base + acc.size + (n + 1) * k) + c with hT + -- Body-step cost `tb ≤ T`. + have htb : tb ≤ T := by + have h1 := hc env (.data acc) (.data v) tb sb hpa + have h2 : accessedEnvSizeFun₁ body env (.data acc) ≤ base + acc.size := by + rw [hbase] + simpa using accessedEnvSizeFun₁_le_closure_add body env (.data acc) + have : base + acc.size ≤ base + acc.size + (n + 1) * k := Nat.le_add_right _ _ + calc tb ≤ c * accessedEnvSizeFun₁ body env (.data acc) + c := h1 + _ ≤ c * (base + acc.size) + c := Nat.add_le_add_right (Nat.mul_le_mul_left c h2) c + _ ≤ T := Nat.add_le_add_right (Nat.mul_le_mul_left c this) c + -- One-step size growth `v.size ≤ acc.size + k`. + have hvk : v.size ≤ acc.size + k := by + simpa using hgrow env (.data acc) (.data v) tb' sb' hpb + -- Recursive bound on the remaining `n` iterations. + have htr : tr ≤ n * T + (acc.size + (n + 1) * k) := by + have hih := ih tr sr h_rest' + have hmono : c * (base + v.size + n * k) + c ≤ T := by + rw [hT] + have hb : base + v.size + n * k ≤ base + acc.size + (n + 1) * k := by + rw [add_one_mul]; omega + exact Nat.add_le_add_right (Nat.mul_le_mul_left c hb) c + have hlast : v.size + n * k ≤ acc.size + (n + 1) * k := by rw [add_one_mul]; omega + calc tr ≤ n * (c * (base + v.size + n * k) + c) + (v.size + n * k) := hih + _ ≤ n * T + (acc.size + (n + 1) * k) := + Nat.add_le_add (Nat.mul_le_mul_left n hmono) hlast + calc tb + tr ≤ T + (n * T + (acc.size + (n + 1) * k)) := Nat.add_le_add htb htr + _ = (n + 1) * T + (acc.size + (n + 1) * k) := by rw [add_one_mul n T]; omega + -- Collapse the core bound into the public `C`-shape. + intro acc r n t s h_iter h_sem + have hcore := core acc r n t s h_iter h_sem + set P := accessedEnvSizeFun₁ body env (.data acc) with hP + have hbaseP : base ≤ P := by + rw [hbase, hP]; exact accessedEnvSizeFun₁_closure_le body env (.data acc) + set Mt := P + acc.size + n with hMt + have hGMt : base + acc.size ≤ Mt := by omega + have hnMt : n ≤ Mt := by omega + have haccMt : acc.size ≤ Mt := by omega + -- `n ≤ n * Mt` (trivial when `n = 0`, else `Mt ≥ n ≥ 1`). + have hnq : n ≤ n * Mt := by + rcases Nat.eq_zero_or_pos n with h | h + · simp [h] + · have h1 : 1 ≤ Mt := le_trans h hnMt + calc n = n * 1 := (Nat.mul_one n).symm + _ ≤ n * Mt := Nat.mul_le_mul_left n h1 + have hn2 : n * n ≤ n * Mt := Nat.mul_le_mul_left n hnMt + -- Per-monomial bounds, all dominated by multiples of `n * Mt`. + have p1 : c * (n * (base + acc.size)) ≤ c * (n * Mt) := + Nat.mul_le_mul_left c (Nat.mul_le_mul_left n hGMt) + have p2 : c * k * (n * n) ≤ c * k * (n * Mt) := Nat.mul_le_mul_left (c * k) hn2 + have p3 : c * n ≤ c * (n * Mt) := Nat.mul_le_mul_left c hnq + have p4 : k * n ≤ k * (n * Mt) := Nat.mul_le_mul_left k hnq + nlinarith [hcore, p1, p2, p3, p4, haccMt] + +/-- Internal inductive core for `WhileIterates.space_bound_of_linear_body`. Like the time core, but +space is a *maximum* over iterations, so the per-iteration linear space bound collapses to its value +at the final accumulator size; no `sum_range_affine_le` is needed. -/ +lemma WhileIterates.whileSem_space_le {body : PB → PB} + (h_body : LinearFun₁ body) (h_growth : AdditiveGrowthFun₁ body) : + ∃ C, ∀ (env : List Value) (acc r : Data) (n : ℕ) {t s : ℕ}, + WhileIterates env body acc r n → + WhileSem (.closure (body (.var env.length) (env.length + 1)) env) acc r t s → + s ≤ C * (accessedEnvSizeFun₁ body env (.data acc) + acc.size + n) + C := by + sorry + +/-- **While-loop time complexity, `a = 1` regime.** If the body is linear-time/space (`LinearFun₁`) +and grows the accumulator additively (`AdditiveGrowthFun₁`), then for a single constant `C` +depending only on `body`, every run of the loop `while_ (.var init) body` (accumulator at slot +`init`, `EnvEnc`) that iterates the body exactly `n` times costs time at most +`C * ((n + 1) * (M + n)) + C`, where `M = accessedEnvSizeFun₁ body env (.data acc) + acc.size`. The +constant `C` is quantified *outside* `env`, `n`, and the run. The bound is `O((n + 1) · (M + n))`, +i.e. quadratic in the iteration count. + +The `(n + 1)` factor (rather than `n`) is forced by the `n = 0` case: the loop still pays `acc.size` +for the initial `.var init` read and the `WhileSem.halt` step, which are `≤ M` but not bounded by +the additive constant `C`, so the leading term must survive at `n = 0`. -/ +theorem WhileIterates.time_bound_of_linear_body {body : PB → PB} + (h_body : LinearFun₁ body) (h_growth : AdditiveGrowthFun₁ body) : + ∃ C, ∀ (env : List Value) (init : ℕ) (acc r : Data) (n : ℕ) {t s : ℕ}, + EnvEnc env init acc → + WhileIterates env body acc r n → + ProgSem env (PB.while_ (.var init) body env.length) (.data r) t s → + t ≤ C * ((n + 1) * (accessedEnvSizeFun₁ body env (.data acc) + acc.size + n)) + C := by + obtain ⟨C₀, hcore⟩ := WhileIterates.whileSem_time_le h_body h_growth + refine ⟨max C₀ 2, ?_⟩ + intro env init acc r n t s h_env h_iter h_prog + -- Expose the `while_` program as an explicit `Prog.while_` and invert it. + have hprog' : ProgSem env + (.while_ (.var init) (.fn (body (.var env.length) (env.length + 1)))) (.data r) t s := h_prog + cases hprog' with + | while_ h_init h_body h_while => + -- The `init` read produces the accumulator (via `EnvEnc`) at cost `acc.size`. + obtain ⟨hv, ht_init, -⟩ := ProgSem.var_inv h_init + have he : env[init]?.getD Value.empty = Value.data acc := by simpa using h_env [] + injection hv.trans he with hacc + rw [hacc] at h_while ht_init + simp only [Value.size_data] at ht_init + -- The `fn` build produces the loop-body closure; its cost is bounded by `accessedEnvSizeFun₁`. + cases h_body + have h_tb := accessedEnvSizeFun₁_closure_le body env (.data acc) + -- The loop iteration cost is handled by the inductive core. + set M := accessedEnvSizeFun₁ body env (.data acc) with hMdef + set P := M + acc.size + n with hPdef + have hCn : C₀ * (n * P) ≤ max C₀ 2 * (n * P) := mul_le_mul_left (le_max_left C₀ 2) _ + have hCP : 2 * P ≤ max C₀ 2 * P := mul_le_mul_left (le_max_right C₀ 2) _ + grind + +/-- **While-loop space complexity, `a = 1` regime.** Space analogue of +`WhileIterates.time_bound_of_linear_body`. Space is the *maximum* over iterations (not a sum), so +the per-iteration linear space bound collapses to its value at the final accumulator size, giving +`C * (M + n) + C` — linear in the iteration count. Here the additive `M` already survives at `n = 0` +(covering the `.var init` read and `WhileSem.halt`'s `acc.size` cost), so no `(n + 1)` is needed. -/ +theorem WhileIterates.space_bound_of_linear_body {body : PB → PB} + (h_body : LinearFun₁ body) (h_growth : AdditiveGrowthFun₁ body) : + ∃ C, ∀ (env : List Value) (init : ℕ) (acc r : Data) (n : ℕ) {t s : ℕ}, + EnvEnc env init acc → + WhileIterates env body acc r n → + ProgSem env (PB.while_ (.var init) body env.length) (.data r) t s → + s ≤ C * (accessedEnvSizeFun₁ body env (.data acc) + acc.size + n) + C := by + sorry + ------------------- Resource Consumption ------------------------- -- /-- Resource-erased relational semantics of a program builder. -/ diff --git a/Cslib/Computability/Machines/RTM/Prog.lean b/Cslib/Computability/Machines/RTM/Prog.lean index 0476541e0..eead15069 100644 --- a/Cslib/Computability/Machines/RTM/Prog.lean +++ b/Cslib/Computability/Machines/RTM/Prog.lean @@ -277,10 +277,63 @@ lemma ProgSem.size_le {σ : List Value} {p : Prog} {v : Value} {t s : ℕ} | while_ | fn | app | mk | halt | step => grind [Value.size_data, Data.cons_size, Data.asList_l] +/-- Value-determinism of the relational semantics: a program evaluates to at most one value in a +given environment. The mutually-defined `AppSem`/`WhileSem` relations are value-deterministic too. +The potential branch overlaps (`elim_nil`/`elim_cons`, `ifEq_then`/`ifEq_else`) are ruled out by +value-determinism of the scrutinee / compared values, supplied by the induction hypotheses. -/ +theorem ProgSem.value_det {σ : List Value} {p : Prog} {v₁ : Value} {t₁ s₁ : ℕ} + (h₁ : ProgSem σ p v₁ t₁ s₁) : + ∀ (v₂ : Value) (t₂ s₂ : ℕ), ProgSem σ p v₂ t₂ s₂ → v₁ = v₂ := by + induction h₁ using ProgSem.rec + (motive_2 := fun f a r₁ _ _ _ => + ∀ (r₂ : Value) (t₂ s₂ : ℕ), AppSem f a r₂ t₂ s₂ → r₁ = r₂) + (motive_3 := fun b acc r₁ _ _ _ => + ∀ (r₂ : Data) (t₂ s₂ : ℕ), WhileSem b acc r₂ t₂ s₂ → r₁ = r₂) with + | var | empty | fn => rintro _ _ _ h₂; cases h₂; rfl + | cons _ _ ih₁ ih₂ => + rintro _ _ _ h₂; cases h₂ with + | cons h₁' h₂' => have := ih₁ _ _ _ h₁'; have := ih₂ _ _ _ h₂'; grind + | elim_nil _ _ ih_v _ => + rintro _ _ _ h₂; cases h₂ with + | elim_nil h_v' _ => grind + | elim_cons h_v' _ _ _ => have := ih_v _ _ _ h_v'; grind + | elim_cons _ _ _ _ ih_v ih_cs ih₁ ih₂ => + rintro _ _ _ h₂; cases h₂ with + | elim_nil h_v' _ => have := ih_v _ _ _ h_v'; grind + | elim_cons h_v' h_cs' h_a₁' h_a₂' => + have := ih_v _ _ _ h_v'; have := ih_cs _ _ _ h_cs' + grind + | ifEq_then _ _ _ ih_x ih_y ih_then => + rintro _ _ _ h₂; cases h₂ with + | ifEq_then h_x' _ h_then' => have := ih_then _ _ _ h_then'; grind + | ifEq_else h_x' h_y' h_neq _ => + have := ih_x _ _ _ h_x'; have := ih_y _ _ _ h_y'; grind + | ifEq_else _ _ _ _ ih_x ih_y ih_else => + rintro _ _ _ h₂; cases h₂ with + | ifEq_then h_x' h_y' _ => have := ih_x _ _ _ h_x'; have := ih_y _ _ _ h_y'; grind + | ifEq_else _ _ _ h_else' => have := ih_else _ _ _ h_else'; grind + | while_ _ _ _ ih_init ih_body ih_while => + rintro _ _ _ h₂; cases h₂ with + | while_ h_init' h_body' h_while' => + have := ih_init _ _ _ h_init'; have := ih_body _ _ _ h_body'; grind + | app _ _ _ ih_fn ih_arg ih_app => + rintro _ _ _ h₂; cases h₂ with + | app h_fn' h_arg' h_app' => + have := ih_fn _ _ _ h_fn'; have := ih_arg _ _ _ h_arg'; grind + | mk _ ih_body => + rename_i h₂; cases h₂ with + | mk h_body' => exact ih_body _ _ _ h_body' + | halt _ + | step _ _ _ ih_app ih_rest => + rename_i h₂; cases h₂ with + | halt h_stop => grind + | step _ h_app' h_rest' => grind + /-- The program `p` computes the value `y` from the value `x` in time `t` and space `s`. -/ def Prog.ComputesInTimeAndSpace (p : Prog) (x y : Data) (t : ℕ) (s : ℕ) : Prop := ProgSem [.data x] p (.data y) t s + /-- The program `p` computes the function `f` (on binary strings) in time `t` and space `s`. This is the main definition that defines complexity for this computation model. -/ def Prog.ComputesBoolFunInTimeAndSpace