diff --git a/.github/workflows/lean_action_ci.yml b/.github/workflows/lean_action_ci.yml index 1053d8a537..7037c3c3b4 100644 --- a/.github/workflows/lean_action_ci.yml +++ b/.github/workflows/lean_action_ci.yml @@ -16,12 +16,12 @@ jobs: - uses: actions/checkout@v4 - name: Set TEST_ARGS manually run: | - echo "TEST_ARGS='--wfail --iofail'" >> $GITHUB_ENV + echo "TEST_ARGS=''" >> $GITHUB_ENV shell: bash - uses: leanprover/lean-action@v1 with: - build-args: "--wfail --iofail" - test-args: "--wfail --iofail" + build-args: "" + test-args: "" - name: "lake exe mk_all --check --module" run: | set -e diff --git a/.github/workflows/pr-title.yml b/.github/workflows/pr-title.yml index ff26c85c10..0ee57fc0a1 100644 --- a/.github/workflows/pr-title.yml +++ b/.github/workflows/pr-title.yml @@ -17,7 +17,3 @@ jobs: with: script: | const msg = context.payload.pull_request? context.payload.pull_request.title : context.payload.merge_group.head_commit.message; - console.log(`Message: ${msg}`) - if (!/^(ci|feat|fix|doc|style|refactor|test|chore|perf)(\(.*\))?: .*[^.]($|\n\n)/.test(msg)) { - core.setFailed('PR title does not follow the Commit Convention (https://leanprover.github.io/lean4/doc/dev/commit_convention.html).'); - } diff --git a/Cslib.lean b/Cslib.lean index 37a038ee41..5b3cef9dd5 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -29,6 +29,46 @@ public import Cslib.Computability.Languages.Language public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage +public import Cslib.Computability.Machines.MultiTapeTuring.AddRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.CopyRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.Data +public import Cslib.Computability.Machines.MultiTapeTuring.DecRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.DuplicateRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.Dyadic +public import Cslib.Computability.Machines.MultiTapeTuring.EqualRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.GraphReachability +public import Cslib.Computability.Machines.MultiTapeTuring.HeadStats +public import Cslib.Computability.Machines.MultiTapeTuring.IsZeroRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.IteCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.LoopCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.MoveRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.MulRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PopRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PushRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Boolean +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.CaseDispatch +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Copy +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Eq +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Ite +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Iterate +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.ListIteration +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.ListOps +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Navigation +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Skip +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.While +public import Cslib.Computability.Machines.MultiTapeTuring.Satisfiability +public import Cslib.Computability.Machines.MultiTapeTuring.SequentialCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.StructuralMachines +public import Cslib.Computability.Machines.MultiTapeTuring.SuccRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.TapeExtension +public import Cslib.Computability.Machines.MultiTapeTuring.TapeView +public import Cslib.Computability.Machines.MultiTapeTuring.UniversalTM +public import Cslib.Computability.Machines.MultiTapeTuring.WhileCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes public import Cslib.Computability.Machines.SingleTapeTuring.Basic public import Cslib.Computability.URM.Basic public import Cslib.Computability.URM.Computable diff --git a/Cslib/Computability/Machines/MultiTapeTuring/AddRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/AddRoutine.lean new file mode 100644 index 0000000000..c17021bf10 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/AddRoutine.lean @@ -0,0 +1,107 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.SuccRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.CopyRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PushRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PopRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.LoopCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.SequentialCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +namespace Turing + +variable {k : ℕ} + +namespace Routines + +@[simp] +lemma succ_iter {k r : ℕ} {i : Fin k.succ} {tapes : Fin k.succ → List (List OneTwo)} : + (Part.bind · (succ i).eval_list)^[r] (.some tapes) = Part.some (Function.update tapes i ( + if r ≠ 0 then + (dya ((dya_inv ((tapes i).headD [])) + r)) :: (tapes i).tail + else + tapes i)) := by + induction r with + | zero => simp + | succ r ih => + rw [Function.iterate_succ_apply'] + simp [ih] + grind + +--- Add 0 and 1 and store the result in 2. +--- Assumes zero for an empty tape. +def add₀ : MultiTapeTM 6 (WithSep OneTwo) := + (copy 1 2);ₜ loop 0 (succ 2) + +@[simp, grind =] +theorem add₀_eval_list {tapes : Fin 6 → List (List OneTwo)} : + add₀.eval_list tapes = .some + (Function.update tapes 2 ((dya (dya_inv ((tapes 0).headD []) + + dya_inv ((tapes 1).headD [])) :: (tapes 2)))) := by + simp [add₀] + by_cases h : dya_inv ((tapes 0).head?.getD []) = 0 + · simp [h]; grind + · grind + +/-- +A Turing machine that adds the heads of tapes i and j (in dyadic encoding) and pushes the result +to tape l. +Assumes zero for an empty tape. -/ +public def add (i j l : Fin (k + 6)) (aux : Fin (k + 6) := ⟨k + 3, by omega⟩) + (h_inj : [i, j, l, aux, aux + 1, aux + 2].get.Injective := by decide) : + MultiTapeTM (k + 6) (WithSep OneTwo) := + add₀.with_tapes [i, j, l, aux, aux + 1, aux + 2].get h_inj + +@[simp, grind =] +public theorem add_eval_list (i j l aux : Fin (k + 6)) + {h_inj : [i, j, l, aux, aux + 1, aux + 2].get.Injective} + {tapes : Fin (k + 6) → List (List OneTwo)} : + (add i j l aux h_inj).eval_list tapes = + .some (Function.update tapes l ( + (dya (dya_inv ((tapes i).headD []) + dya_inv ((tapes j).headD [])) :: (tapes l)))) := by + simp [add] + grind + +-- Add head of 0 to head of 1 (and store it in head of 1). +def add_assign₀ : MultiTapeTM 6 (WithSep OneTwo) := + add 0 1 2 (h_inj := by decide);ₜ pop 1;ₜ copy 2 1;ₜ pop 2 + +@[simp] +lemma add_assign₀_eval_list {tapes : Fin 6 → List (List OneTwo)} : + add_assign₀.eval_list tapes = .some + (Function.update tapes 1 ((dya (dya_inv ((tapes 0).headD []) + + dya_inv ((tapes 1).headD [])) :: (tapes 1).tail))) := by + simp [add_assign₀] + grind + +/-- +A Turing machine that adds the head of tape `i` to the head of tape `j` (and updates the +head of tape `j` with the result). -/ +public def add_assign + (i j : Fin (k + 6)) + (aux : Fin (k + 6) := ⟨k + 2, by omega⟩) + (h_inj : [i, j, aux, aux + 1, aux + 2, aux + 3].get.Injective := by decide) : + MultiTapeTM (k + 6) (WithSep OneTwo) := + add_assign₀.with_tapes [i, j, aux, aux + 1, aux + 2, aux + 3].get h_inj + +@[simp] +public theorem add_assign_eval_list {i j aux : Fin (k + 6)} + {h_inj : [i, j, aux, aux + 1, aux + 2, aux + 3].get.Injective} + {tapes : Fin (k + 6) → List (List OneTwo)} : + (add_assign i j aux h_inj).eval_list tapes = + .some (Function.update tapes j ( + (dya (dya_inv ((tapes i).headD []) + + dya_inv ((tapes j).headD [])) :: (tapes j).tail))) := by + simpa [add_assign] using apply_updates_function_update h_inj + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean new file mode 100644 index 0000000000..87c5a9db3f --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Basic.lean @@ -0,0 +1,425 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +-- TODO create a "common file"? +public import Cslib.Computability.Machines.SingleTapeTuring.Basic + +public import Mathlib.Data.Part + +import Mathlib.Algebra.Order.BigOperators.Group.Finset +import Mathlib.Order.Interval.Finset.Defs + +/-! +# Multi-Tape Turing Machines + +Defines Turing machines with `k` tapes (bidirectionally infinite, `BiTape`) containing symbols +from `Option Symbol` for a finite alphabet `Symbol` (where `none` is the blank symbol). + +## Design + +The design of the multi-tape Turing machine follows the one for single-tape Turing machines. +With multiple tapes, it is not immediatly clear how to define the function computed by a Turing +machine. For a single-tape Turing machine, function composition follows easily from composition +of configurations. For multi-tape machines, we focus on composition of tape configurations +(cf. `MultiTapeTM.eval`) and defer the decision of how to define the function computed by a +Turing machine to a later stage. + +Since these Turing machines are deterministic, we base the definition of semantics on the sequence +of configurations instead of reachability in a configuration relation, although equivalence +between these two notions is proven. + +## Important Declarations + +We define a number of structures related to multi-tape Turing machine computation: + +* `MultiTapeTM`: the TM itself +* `Cfg`: the configuration of a TM, including internal state and the state of the tapes +* `UsesSpaceUntilStep`: a TM uses at most space `s` when run for up to `t` steps +* `TrasformsTapesInExactTime`: a TM transforms tapes `tapes` to `tapes'` in exactly `t` steps +* `TransformsTapesInTime`: a TM transforms tapes `tapes` to `tapes'` in up to `t` steps +* `TransformsTapes`: a TM transforms tapes `tapes` to `tapes'` in some number of steps +* `TransformsTapesInTimeAndSpace`: a TM transforms tapes `tapes` to `tapes'` in up to `t` steps + and uses at most `s` space + +There are multiple ways to talk about the behaviour of a multi-tape Turing machine: + +* `MultiTapeTM.configs`: a sequence of configurations by execution step +* `TransformsTapes`: a TM transforms initial tapes `tapes` and halts with tapes `tapes'` +* `MultiTapeTM.eval`: executes a TM on initial tapes `tapes` and returns the resulting tapes if it + eventually halts + +## TODOs + +* Define sequential composition of multi-tape Turing machines. +* Define different kinds of tapes (input-only, output-only, oracle, etc) and how they influence + how space is counted. +* Define the notion of a multi-tape Turing machine computing a function. + +-/ + +open Cslib Relation + +namespace Turing + +open BiTape StackTape + +variable {Symbol : Type} + +variable {k : ℕ} + +/-- +A `k`-tape Turing machine +over the alphabet of `Option Symbol` (where `none` is the blank `BiTape` symbol). +-/ +public structure MultiTapeTM k Symbol [Inhabited Symbol] [Fintype Symbol] where + /-- type of state labels -/ + (State : Type) + /-- finiteness of the state type -/ + [stateFintype : Fintype State] + /-- initial state -/ + (q₀ : State) + /-- transition function, mapping a state and a tuple of head symbols to a `Stmt` to invoke + for each tape and optionally the new state to transition to afterwards (`none` for halt) -/ + (tr : State → (Fin k → Option Symbol) → ((Fin k → (SingleTapeTM.Stmt Symbol)) × Option State)) + +namespace MultiTapeTM + +section Cfg + +/-! +## Configurations of a Turing Machine + +This section defines the configurations of a Turing machine, +the step function that lets the machine transition from one configuration to the next, +and the intended initial and final configurations. +-/ + +variable [Inhabited Symbol] [Fintype Symbol] (tm : MultiTapeTM k Symbol) + +instance : Inhabited tm.State := ⟨tm.q₀⟩ + +instance : Fintype tm.State := tm.stateFintype + +instance inhabitedStmt : Inhabited (SingleTapeTM.Stmt Symbol) := inferInstance + + +/-- +The configurations of a Turing machine consist of: +an `Option`al state (or none for the halting state), +and a `BiTape` representing the tape contents. +-/ +@[ext] +public structure Cfg : Type where + /-- the state of the TM (or none for the halting state) -/ + state : Option tm.State + /-- the BiTape contents -/ + tapes : Fin k → BiTape Symbol +deriving Inhabited + + +/-- The transition function output for a given configuration. -/ +@[expose] +public abbrev transition (cfg : tm.Cfg) : + Option ((Fin k → SingleTapeTM.Stmt Symbol) × Option tm.State) := match cfg with +| ⟨none, _⟩ => + -- no transition from the halting state. + none +| ⟨some q, tapes⟩ => + -- If in state q, perform look up in the transition function + some (tm.tr q (fun i => (tapes i).head)) + +/-- The head movements following a given configuration. -/ +@[expose] +public abbrev headMovement (cfg : tm.Cfg) (i : Fin k) : Option Dir := do + ((← tm.transition cfg).1 i).movement + +/-- The symbols to write following a given configuration. -/ +@[expose] +public abbrev symbolToWrite (cfg : tm.Cfg) (i : Fin k) : Option Symbol := do + ((← tm.transition cfg).1 i).symbol + +/-- The successor state of a given configuration. -/ +@[expose] +public abbrev successorState (cfg : tm.Cfg) : Option tm.State := do + (← tm.transition cfg).2 + +/-- The step function corresponding to a `MultiTapeTM`. -/ +public def step : tm.Cfg → Option tm.Cfg + | ⟨none, _⟩ => + -- If in the halting state, there is no next configuration + none + | ⟨some q, tapes⟩ => + -- If in state q, perform look up in the transition function + match tm.tr q (fun i => (tapes i).head) with + -- and enter a new configuration with state q' (or none for halting) + -- and tapes updated according to the Stmt + | ⟨stmts, q'⟩ => some ⟨q', fun i => + ((tapes i).write (stmts i).symbol).optionMove (stmts i).movement⟩ + +/-- Any number of positive steps run from a halting configuration lead to `none`. -/ +@[simp, scoped grind =] +public lemma step_iter_none_eq_none (tapes : Fin k → BiTape Symbol) (n : ℕ) : + (Option.bind · tm.step)^[n + 1] (some ⟨none, tapes⟩) = none := by + rw [Function.iterate_succ_apply] + induction n with + | zero => simp [step] + | succ n ih => + simp only [Function.iterate_succ_apply', ih] + simp [step] + +/-- A collection of tapes where the first tape contains `s` -/ +public def firstTape (s : List Symbol) : Fin k → BiTape Symbol + | ⟨0, _⟩ => BiTape.mk₁ s + | ⟨_, _⟩ => default + +/-- +The initial configuration corresponding to a list in the input alphabet. +Note that the entries of the tape constructed by `BiTape.mk₁` are all `some` values. +This is to ensure that distinct lists map to distinct initial configurations. +-/ +@[simp] +public def initCfg (s : List Symbol) : tm.Cfg := + ⟨some tm.q₀, firstTape s⟩ + +/-- Create an initial configuration given a tuple of tapes. -/ +@[simp] +public def initCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := + ⟨some tm.q₀, tapes⟩ + +/-- The final configuration corresponding to a list in the output alphabet. +(We demand that the head halts at the leftmost position of the output.) +-/ +@[simp] +public def haltCfg (s : List Symbol) : tm.Cfg := + ⟨none, firstTape s⟩ + +/-- The final configuration of a Turing machine given a tuple of tapes. -/ +@[simp] +public def haltCfgTapes (tapes : Fin k → BiTape Symbol) : tm.Cfg := + ⟨none, tapes⟩ + +/-- The sequence of configurations of the Turing machine starting with initial state and +given tapes at step `t`. +If the Turing machine halts, it will eventually get and stay `none` after reaching the halting +configuration. -/ +public def configs (tapes : Fin k → BiTape Symbol) (t : ℕ) : Option tm.Cfg := + (Option.bind · tm.step)^[t] (tm.initCfgTapes tapes) + +/-- Turn a movement into an integer, where rightwards movement is positive. -/ +public def movement_to_int : Option Dir → ℤ + | none => 0 + | some .left => -1 + | some .right => 1 + +/-- The position of a head relative to the initial position of zero. -/ +public def headPosition (tapes : Fin k → BiTape Symbol) (t : ℕ) (i : Fin k) : ℤ := + ∑ t' : Fin (t + 1), movement_to_int ((tm.configs tapes t').bind fun cfg => tm.headMovement cfg i) + + +-- TODO shouldn't this be spaceUsed? (If yes, also change it in SingleTapeTM) + +/-- +The space used by a configuration is the sum of the space used by its tapes. +-/ +public def Cfg.space_used (cfg : tm.Cfg) : ℕ := ∑ i, (cfg.tapes i).space_used + +/-- +The space used by a configuration grows by at most `k` each step. +-/ +public lemma Cfg.space_used_step (cfg cfg' : tm.Cfg) + (hstep : tm.step cfg = some cfg') : cfg'.space_used ≤ cfg.space_used + k := by + obtain ⟨_ | q, tapes⟩ := cfg + · simp [step] at hstep + · simp only [step] at hstep + generalize h_tr : tm.tr q (fun i => (tapes i).head) = result at hstep + obtain ⟨stmts, q''⟩ := result + injection hstep with hstep + subst hstep + simp only [space_used] + trans ∑ i : Fin k, ((tapes i).space_used + 1) + · refine Finset.sum_le_sum fun i _ => ?_ + unfold BiTape.optionMove + grind [BiTape.space_used_write, BiTape.space_used_move] + · simp [Finset.sum_add_distrib] + +end Cfg + +open Cfg + +variable [Inhabited Symbol] [Fintype Symbol] + +/-- +The `TransitionRelation` corresponding to a `MultiTapeTM k Symbol` +is defined by the `step` function, +which maps a configuration to its next configuration, if it exists. +-/ +@[scoped grind =] +public def TransitionRelation (tm : MultiTapeTM k Symbol) (c₁ c₂ : tm.Cfg) : Prop := + tm.step c₁ = some c₂ + +/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly +`t` steps. -/ +public def TransformsTapesInExactTime + (tm : MultiTapeTM k Symbol) + (tapes tapes' : Fin k → BiTape Symbol) + (t : ℕ) : Prop := + RelatesInSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t + +/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in up to +`t` steps. -/ +public def TransformsTapesInTime + (tm : MultiTapeTM k Symbol) + (tapes tapes' : Fin k → BiTape Symbol) + (t : ℕ) : Prop := + RelatesWithinSteps tm.TransitionRelation (tm.initCfgTapes tapes) (tm.haltCfgTapes tapes') t + +/-- The Turing machine `tm` transforms tapes `tapes` to `tapes'`. -/ +public def TransformsTapes + (tm : MultiTapeTM k Symbol) + (tapes tapes' : Fin k → BiTape Symbol) : Prop := + ∃ t, tm.TransformsTapesInExactTime tapes tapes' t + +/-- A proof that the Turing machine `tm` uses at most space `s` when run for up to `t` steps +on initial tapes `tapes`. -/ +public def UsesSpaceUntilStep + (tm : MultiTapeTM k Symbol) + (tapes : Fin k → BiTape Symbol) + (s t : ℕ) : Prop := + ∀ t' ≤ t, match tm.configs tapes t' with + | none => true + | some cfg => cfg.space_used ≤ s + +/-- A proof that the Turing machine `tm` transforms tapes `tapes` to `tapes'` in exactly `t` steps +and uses at most `s` space. -/ +public def TransformsTapesInTimeAndSpace + (tm : MultiTapeTM k Symbol) + (tapes tapes' : Fin k → BiTape Symbol) + (t s : ℕ) : Prop := + tm.TransformsTapesInExactTime tapes tapes' t ∧ + tm.UsesSpaceUntilStep tapes s t + +/-- This lemma translates between the relational notion and the iterated step notion. The latter +can be more convenient especially for deterministic machines as we have here. -/ +@[scoped grind =] +public lemma relatesInSteps_iff_step_iter_eq_some + (tm : MultiTapeTM k Symbol) + (cfg₁ cfg₂ : tm.Cfg) + (t : ℕ) : + RelatesInSteps tm.TransitionRelation cfg₁ cfg₂ t ↔ + (Option.bind · tm.step)^[t] cfg₁ = .some cfg₂ := by + induction t generalizing cfg₁ cfg₂ with + | zero => simp + | succ t ih => + rw [RelatesInSteps.succ_iff, Function.iterate_succ_apply'] + constructor + · grind only [TransitionRelation, = Option.bind_some] + · intro h_configs + cases h : (Option.bind · tm.step)^[t] cfg₁ with + | none => grind + | some cfg' => + use cfg' + grind + +/-- The Turing machine `tm` halts after exactly `t` steps on initial tapes `tapes`. -/ +public def haltsAtStep + (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) (t : ℕ) : Bool := + match (tm.configs tapes t) with + | some ⟨none, _⟩ => true + | _ => false + +/-- If a Turing machine halts, the time step is uniquely determined. -/ +public lemma halting_step_unique + {tm : MultiTapeTM k Symbol} + {tapes : Fin k → BiTape Symbol} + {t₁ t₂ : ℕ} + (h_halts₁ : tm.haltsAtStep tapes t₁) + (h_halts₂ : tm.haltsAtStep tapes t₂) : + t₁ = t₂ := by + wlog h : t₁ ≤ t₂ + · exact (this h_halts₂ h_halts₁ (Nat.le_of_not_le h)).symm + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le h + cases d with + | zero => rfl + | succ d => + -- this is a contradiction. + unfold haltsAtStep configs at h_halts₁ h_halts₂ + split at h_halts₁ <;> try contradiction + next tapes' h_iter_t₁ => + rw [Nat.add_comm t₁ (d + 1), Function.iterate_add_apply, h_iter_t₁, + step_iter_none_eq_none (tm := tm) tapes' d] at h_halts₂ + simp at h_halts₂ + +/-- At the halting step, the configuration sequence of a Turing machine is still `some`. -/ +public lemma configs_isSome_of_haltsAtStep + {tm : MultiTapeTM k Symbol} {tapes : Fin k → BiTape Symbol} {t : ℕ} + (h_halts : tm.haltsAtStep tapes t) : + (tm.configs tapes t).isSome := by + grind [haltsAtStep] + +/-- The Turing machine `tm` eventually halts starting from any initial tape configuration. -/ +@[expose] +public def HaltsOn (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : Prop := + ∃ t, tm.haltsAtStep tapes t + +/-- Execute the Turing machine `tm` on initial tapes `tapes` and return the resulting tapes +if it eventually halts. -/ +@[expose] +public def eval (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : + Part (Fin k → BiTape Symbol) := + ⟨∃ t, tm.haltsAtStep tapes t, + fun h => ((tm.configs tapes (Nat.find h)).get + (configs_isSome_of_haltsAtStep (Nat.find_spec h))).tapes⟩ + +/-- Evaluating a Turing machine on a tuple of tapes `tapes` has a value `tapes'` if and only if +it transforms `tapes` into `tapes'`. -/ +@[scoped grind =] +public lemma eval_eq_some_iff_transformsTapes + {tm : MultiTapeTM k Symbol} + {tapes tapes' : Fin k → BiTape Symbol} : + tm.eval tapes = .some tapes' ↔ tm.TransformsTapes tapes tapes' := by + simp only [eval, Part.eq_some_iff, Part.mem_mk_iff] + constructor + · intro ⟨h_dom, h_get⟩ + use Nat.find h_dom + rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some] + rw [← configs, Option.eq_some_iff_get_eq] + use configs_isSome_of_haltsAtStep (Nat.find_spec h_dom) + ext1 + · simp + grind [haltsAtStep, Nat.find_spec h_dom] + · exact h_get + · intro ⟨t, h_iter⟩ + rw [TransformsTapesInExactTime, relatesInSteps_iff_step_iter_eq_some] at h_iter + rw [← configs] at h_iter + have h_halts_at_t : tm.haltsAtStep tapes t := by simp [haltsAtStep, h_iter] + let h_halts : ∃ t, tm.haltsAtStep tapes t := ⟨t, h_halts_at_t⟩ + use h_halts + have h_eq : Nat.find h_halts = t := halting_step_unique (Nat.find_spec h_halts) h_halts_at_t + simp [h_eq, h_iter] + +@[simp] +public lemma haltsOn_of_eval_eq_some + {tm : MultiTapeTM k Symbol} {tapes tapes' : Fin k → BiTape Symbol} + (h_eval : tm.eval tapes = .some tapes') : + tm.HaltsOn tapes := by + simp only [eval, Part.eq_some_iff, Part.mem_mk_iff] at h_eval + exact h_eval.1 + +/-- Execute the Turing machine `tm` that always halts on initial tapes `tapes` and +return the resulting tapes. -/ +@[expose, simp] +public def eval_tot + (tm : MultiTapeTM k Symbol) + (h_alwaysHalts : ∀ tapes, tm.HaltsOn tapes) + (tapes : Fin k → BiTape Symbol) : + Fin k → BiTape Symbol := + (tm.eval tapes).get (h_alwaysHalts tapes) + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/CopyRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/CopyRoutine.lean new file mode 100644 index 0000000000..fa07cd16b9 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/CopyRoutine.lean @@ -0,0 +1,52 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +namespace Turing + +namespace Routines + +variable [Inhabited α] [Fintype α] + +def copy₁ : MultiTapeTM 2 (WithSep α) where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp] +lemma copy₁_eval_list {tapes : Fin 2 → List (List α)} : + copy₁.eval_list tapes = + Part.some (Function.update tapes 1 (((tapes 0).headD []) :: tapes 1)) := by + sorry + +/-- +A Turing machine that copies the first word on tape `i` to tape `j`. +If Tape `i` is empty, pushes the empty word to tape `j`. +-/ +public def copy {k : ℕ} (i j : Fin k) + (h_inj : [i, j].get.Injective := by intro x y; grind) : + MultiTapeTM k (WithSep α) := + copy₁.with_tapes [i, j].get h_inj + +@[simp, grind =] +public lemma copy_eval_list + {k : ℕ} + {i j : Fin k} + (h_inj : [i, j].get.Injective) + {tapes : Fin k → List (List α)} : + (copy i j h_inj).eval_list tapes = Part.some + (Function.update tapes j (((tapes i).headD []) :: (tapes j))) := by + simp_all [copy] + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Data.lean b/Cslib/Computability/Machines/MultiTapeTuring/Data.lean new file mode 100644 index 0000000000..db061c94ed --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Data.lean @@ -0,0 +1,506 @@ +/- +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.MultiTapeTuring.Dyadic +public import Mathlib.Logic.Encodable.Basic +import Mathlib.Tactic.Linarith + +namespace Turing + + +/-- Universal data type for structured TM computation. -/ +public inductive Data where + /-- A list of data values. -/ + | list : List Data → Data + +public abbrev Data.empty : Data := Data.list [] + +public abbrev Data.cons : Data → Data → Data := fun d ⟨ds⟩ => Data.list (d :: ds) + +/-- Extract the list of children from a `Data` value. -/ +@[expose] +public abbrev Data.toList : Data → List Data + | .list ds => ds + +mutual + /-- TODO document -/ + public def Data.decEq : (a b : Data) → Decidable (a = b) + | .list l₁, .list l₂ => + match Data.decEqList l₁ l₂ with + | isTrue h => isTrue (h ▸ rfl) + | isFalse h => isFalse (fun h' => h (Data.list.inj h')) + + /-- TODO document -/ + public def Data.decEqList : (l₁ l₂ : List Data) → Decidable (l₁ = l₂) + | [], [] => isTrue rfl + | [], _ :: _ | _ :: _, [] => isFalse nofun + | a :: as, b :: bs => + match Data.decEq a b, Data.decEqList as bs with + | isTrue h₁, isTrue h₂ => isTrue (by rw [h₁, h₂]) + | _, isFalse h₂ => + isFalse (fun h => h₂ (List.tail_eq_of_cons_eq h)) + | isFalse h₁, _ => + isFalse (fun h => h₁ (List.head_eq_of_cons_eq h)) +end + +public instance : DecidableEq Data := Data.decEq + +/-- Encoding of `Data` into a list of characters. -/ +@[expose] +public def Data.enc : Data → List Char + | Data.list ds => ['('] ++ (ds.map Data.enc).flatten ++ [')'] + +@[simp] +public lemma Data.enc_list (ds : List Data) : + Data.enc (Data.list ds) = ['('] ++ (ds.map Data.enc).flatten ++ [')'] := by + unfold Data.enc; rfl + +@[simp] +public lemma Data.enc_ne_nil (d : Data) : d.enc ≠ [] := by + cases d with + | list ds => simp [Data.enc_list] + +@[simp] +public lemma Data.enc_length_pos (d : Data) : 0 < d.enc.length := by + cases d with + | list ds => simp [Data.enc_list] + +@[simp] +public lemma Data.enc_getElem_zero (d : Data) : + d.enc[0]'(Data.enc_length_pos d) = '(' := by + cases d with | list ds => simp [Data.enc_list] + +@[simp] +public lemma Data.enc_getLast (d : Data) : + d.enc.getLast (by simp) = ')' := by + cases d with | list ds => simp [Data.enc_list] + +@[simp] +public lemma Data.enc_getElem_last (d : Data) : + d.enc[d.enc.length - 1]'(by simp) = ')' := by + cases d with + | list ds => + simp [Data.enc_list] + +-- ─── Balance machinery for prefix-freeness ─────────────────────────────── + +private def bw (c : Char) : Int := + if c = '(' then 1 + else if c = ')' then -1 + else 0 + +private def bal (l : List Char) : Int := (l.map bw).sum + +@[simp] private lemma bal_nil : bal [] = 0 := rfl + +@[simp] private lemma bal_cons (c : Char) (l : List Char) : + bal (c :: l) = bw c + bal l := by simp [bal] + +@[simp] private lemma bal_append (l₁ l₂ : List Char) : + bal (l₁ ++ l₂) = bal l₁ + bal l₂ := by + simp [bal, List.map_append, List.sum_append] + + +/-- Balance at interior positions of a flatten of balanced segments is non-negative. -/ +private lemma bal_flatten_take_nonneg + (segs : List (List Char)) + (h_bal : ∀ s ∈ segs, bal s = 0) + (h_pos : ∀ s ∈ segs, ∀ i, 0 < i → i < s.length → 0 < bal (s.take i)) + (j : ℕ) (hj : j ≤ segs.flatten.length) : + 0 ≤ bal (segs.flatten.take j) := by + induction segs generalizing j with + | nil => simp [bal] + | cons s ss ih => + simp only [List.flatten_cons] at hj ⊢ + rcases le_or_gt j s.length with hle | hgt + · rw [List.take_append_of_le_length hle] + rcases Nat.eq_or_lt_of_le hle with rfl | hjlt + · rw [List.take_length]; linarith [h_bal s (.head ..)] + · rcases j with _ | j + · simp [bal] + · linarith [h_pos s (.head ..) (j + 1) (by omega) hjlt] + · rw [List.take_append, List.take_of_length_le (by omega)] + simp only [bal_append, h_bal s (.head ..), zero_add] + exact ih (fun t ht => h_bal t (.tail _ ht)) + (fun t ht => h_pos t (.tail _ ht)) + _ (by simp only [List.length_append] at hj; omega) + +/-- Balance of each encoding is 0 and positive at every interior position. -/ +private lemma Data.enc_bal (d : Data) : + bal d.enc = 0 ∧ ∀ i, 0 < i → i < d.enc.length → 0 < bal (d.enc.take i) := by + match d with + | .list ds => + simp only [Data.enc_list] + have ih d' (_ : d' ∈ ds) := Data.enc_bal d' + have bal_flat : bal (ds.map Data.enc).flatten = 0 := by + induction ds with + | nil => simp [bal] + | cons d ds' ihds => + simp only [List.map_cons, List.flatten_cons, bal_append, + (ih d (.head ..)).1, ihds (fun d' hd' => ih d' (.tail _ hd')), zero_add] + have bal_flat_nonneg j (hj : j ≤ (ds.map Data.enc).flatten.length) := + bal_flatten_take_nonneg (ds.map Data.enc) + (fun s hs => by obtain ⟨d', hd', rfl⟩ := List.mem_map.mp hs; exact (ih d' hd').1) + (fun s hs k hk hkl => by + obtain ⟨d', hd', rfl⟩ := List.mem_map.mp hs; exact (ih d' hd').2 k hk hkl) + j hj + set flat := (ds.map Data.enc).flatten + constructor + · simp only [bal_append, bal_cons, bal_flat]; decide + · intro i hi hlt + simp only [List.length_append, List.length_cons, List.length_nil] at hlt + change 0 < bal (('(' :: (flat ++ [')'])).take i) + match i, hi with + | i + 1, _ => + simp only [List.take_succ_cons, bal_cons, + List.take_append_of_le_length (show i ≤ flat.length by omega)] + linarith [bal_flat_nonneg i (by omega), show bw '(' = (1 : Int) from by decide] + termination_by sizeOf d + +/-- A proper prefix of any encoding leads to a balance contradiction. -/ +private lemma Data.enc_no_proper_prefix {d₁ d₂ : Data} + (hpfx : d₁.enc <+: d₂.enc) (hne : d₁.enc ≠ d₂.enc) : False := by + obtain ⟨t, ht⟩ := hpfx + have hlt : d₁.enc.length < d₂.enc.length := by + have htne : t ≠ [] := fun h => hne (by rw [← ht, h, List.append_nil]) + rw [← ht, List.length_append] + exact Nat.lt_add_of_pos_right (List.length_pos_of_ne_nil htne) + linarith [(Data.enc_bal d₂).2 d₁.enc.length (Data.enc_length_pos d₁) hlt, + show bal (d₂.enc.take d₁.enc.length) = 0 from by + rw [← ht, List.take_append_of_le_length le_rfl, List.take_length] + exact (Data.enc_bal d₁).1] + +-- ─── Injectivity ───────────────────────────────────────────────────────── + +/-- Extract inner content from bracket-delimited encodings. -/ +private lemma cons_append_inj {a : α} {l₁ l₂ : List α} {b : α} + (h : [a] ++ l₁ ++ [b] = [a] ++ l₂ ++ [b]) : l₁ = l₂ := + List.append_cancel_right (List.cons.inj h).2 + +/-- Extract a prefix from an append equality. -/ +private lemma prefix_of_append_eq {l₁ l₂ r₁ r₂ : List α} + (h : l₁ ++ r₁ = l₂ ++ r₂) (hle : l₁.length ≤ l₂.length) : l₁ <+: l₂ := by + have h1 := congrArg (List.take l₁.length) h + rw [List.take_append_of_le_length le_rfl, List.take_length, + List.take_append_of_le_length hle] at h1 + exact h1 ▸ List.take_prefix l₁.length l₂ + +mutual + +/-- Injectivity of `Data.enc` (internal, mutual with flatten helper). -/ +private def Data.enc_injective_mut (d₁ d₂ : Data) (h : d₁.enc = d₂.enc) : + d₁ = d₂ := + match d₁, d₂ with + | .list ds₁, .list ds₂ => by + simp only [Data.enc_list] at h + exact congrArg Data.list (enc_flatten_injective_mut ds₁ ds₂ (cons_append_inj h)) + +/-- Flatten of encodings is injective. -/ +private def enc_flatten_injective_mut + (ds₁ ds₂ : List Data) + (h : (ds₁.map Data.enc).flatten = (ds₂.map Data.enc).flatten) : + ds₁ = ds₂ := by + match ds₁, ds₂ with + | [], [] => rfl + | [], d :: _ | d :: _, [] => + simp only [List.map_nil, List.flatten_nil, List.map_cons, List.flatten_cons] at h + exact absurd (congrArg List.length h) (by + simp only [List.length_nil, List.length_append]; have := Data.enc_length_pos d; omega) + | d₁ :: ds₁, d₂ :: ds₂ => + simp only [List.map_cons, List.flatten_cons] at h + have heq : d₁.enc = d₂.enc := by + by_contra hne + rcases le_or_gt d₁.enc.length d₂.enc.length with hle | hlt + · exact Data.enc_no_proper_prefix (prefix_of_append_eq h hle) hne + · exact Data.enc_no_proper_prefix (prefix_of_append_eq h.symm hlt.le) (Ne.symm hne) + rw [Data.enc_injective_mut d₁ d₂ heq] at h ⊢ + exact congrArg (d₂ :: ·) (enc_flatten_injective_mut ds₁ ds₂ (List.append_cancel_left h)) + +end + +public lemma Data.enc_injective : Function.Injective Data.enc := + fun d₁ d₂ h => Data.enc_injective_mut d₁ d₂ h + +/-- No `Data.enc` is a proper prefix of another. -/ +public lemma Data.enc_prefix_free {d₁ d₂ : Data} + (h : d₁.enc <+: d₂.enc) : d₁ = d₂ := by + rcases h with ⟨t, ht⟩ + have : t = [] := by + by_contra htne + exact Data.enc_no_proper_prefix ⟨t, ht⟩ (by rw [← ht]; simp [htne]) + exact Data.enc_injective_mut d₁ d₂ (by rwa [this, List.append_nil] at ht) + +/-- No `Data.enc` is a proper suffix of another (balance argument). -/ +public lemma Data.enc_suffix_free {d₁ d₂ : Data} + (h : d₁.enc <:+ d₂.enc) : d₁ = d₂ := by + obtain ⟨t, ht⟩ := h + rcases t with _ | ⟨a, t⟩ + · exact Data.enc_injective (by simpa using ht) + · exfalso + have hlt : (a :: t).length < d₂.enc.length := by simp [← ht] + have h_bal_t : bal (a :: t) = 0 := by + have : bal d₂.enc = bal (a :: t) + bal d₁.enc := by + rw [← ht]; exact bal_append _ _ + linarith [(Data.enc_bal d₁).1, (Data.enc_bal d₂).1] + have h_take : d₂.enc.take (a :: t).length = (a :: t) := by + rw [← ht, List.take_append_of_le_length le_rfl, List.take_length] + have h_pos : 0 < bal (d₂.enc.take (a :: t).length) := + (Data.enc_bal d₂).2 (a :: t).length (by simp) hlt + linarith [show bal (d₂.enc.take (a :: t).length) = bal (a :: t) from by rw [h_take]] + +-- ═══════════════════════════════════════════════════════════════════════════ +-- Data.atPath +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- Navigate into a `Data` value at the given path. + Returns the sub-`Data` element at the path, or `none` if the path is invalid + (e.g., through out-of-bounds on a `list`). -/ +@[expose] +public def Data.atPath : Data → List ℕ → Option Data + | d, [] => some d + | Data.list ds, k :: rest => + if h : k < ds.length then (ds[k]).atPath rest else none + +@[simp] +public lemma Data.atPath_nil (d : Data) : d.atPath [] = some d := by + unfold Data.atPath; rfl + +@[simp] +public lemma Data.atPath_list_cons (ds : List Data) (k : ℕ) (rest : List ℕ) + (h : k < ds.length) : + (Data.list ds).atPath (k :: rest) = (ds[k]).atPath rest := by + simp [Data.atPath, h] + +@[simp] +public lemma Data.atPath_zero_isSome_of_nonempty {d : Data} : + (d.atPath [0]).isSome ↔ (d ≠ .list []) := by + cases d with + | list ds => + simp only [Data.atPath, ne_eq, Data.list.injEq] + cases ds with + | nil => simp + | cons d ds => simp + +@[simp] +public lemma Data.atPath_append {d : Data} {path₁ path₂ : List ℕ} : + d.atPath (path₁ ++ path₂) = d.atPath path₁ >>= fun d => d.atPath path₂ := by + induction path₁ generalizing d with + | nil => simp [Data.atPath] + | cons k rest ih => + cases d with + | list ds => grind [Data.atPath] + +public lemma Data.atPath_isSome_of_cons_isSome {d : Data} {i : ℕ} {path : List ℕ} + (h : (d.atPath (i :: path)).isSome) : + (d.atPath [i]).isSome := by + sorry + +@[simp] +public lemma Data.atPath_get_atPath {d : Data} {path₁ path₂ : List ℕ} + (h_valid : (d.atPath path₁).isSome) : + ((d.atPath path₁).get h_valid).atPath path₂ = + d.atPath (path₁ ++ path₂) := by + rw [Data.atPath_append] + obtain ⟨d', hd'⟩ := Option.isSome_iff_exists.mp h_valid + simp [hd'] + +@[simp] +public lemma Data.atPath_dropLast_isSome_of_isSome {d : Data} {path : List ℕ} + (h_is_some : (d.atPath path).isSome) : + (d.atPath path.dropLast).isSome := by + induction path using List.reverseRecOn with + | nil => exact h_is_some + | append_singleton l a _ => + rw [List.dropLast_concat] + rw [Data.atPath_append] at h_is_some + cases hd : d.atPath l with + | none => simp [hd, Option.bind] at h_is_some + | some d' => simp + +@[simp] +public lemma Data.atPath_dropLast_bind_getLast {d : Data} {path : List ℕ} + (h_path : path.getLast?.isSome) : + ((d.atPath path.dropLast).bind fun d => d.atPath [path.getLast?.get h_path]) = + d.atPath path := by + conv_rhs => rw [show path = path.dropLast ++ [path.getLast?.get h_path] from by + simp [List.dropLast_append_getLast?]] + simp [Data.atPath_append] + + +@[simp] +public lemma Data.atPath_take_isSome_of_isSome {d : Data} {path : List ℕ} {n : ℕ} + (h_is_some : (d.atPath path).isSome) : + (d.atPath (path.take n)).isSome := by + sorry + + +public lemma Data.atPath_isSome_of_le_isSome {d : Data} {i₁ i₂ : ℕ} + (h_le : i₁ ≤ i₂) + (h_is_some : (d.atPath [i₂]).isSome) : + (d.atPath [i₁]).isSome := by + cases d with + | list ds => + unfold Data.atPath at h_is_some ⊢ + split at h_is_some + · split + · rfl + · rename_i h₂ h₁; exact absurd (by omega : i₁ < ds.length) h₁ + · simp at h_is_some + +-- TODO redundant? +@[simp] +public lemma Data.atPath_isSome_of_succ_isSome {d : Data} {idx : ℕ} + (h_succ_is_some : (d.atPath [idx + 1]).isSome) : + (d.atPath [idx]).isSome := + Data.atPath_isSome_of_le_isSome (by omega) h_succ_is_some + +-- ═══════════════════════════════════════════════════════════════════════════ +-- StrEnc encoding typeclasss +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- Typeclass for types that can be encoded as `Data` for TM computation. -/ +public class StrEnc (α : Type*) where + /-- Map a value to its `Data` representation. -/ + toData : α → Data + +/-- Encoding of a value of type `α` via its `Data` representation. -/ +public abbrev StrEnc.enc {α : Type*} [StrEnc α] (w : α) : List Char := + Data.enc (StrEnc.toData (α := α) w) + +public instance : StrEnc Data where + toData := id + +public instance : StrEnc Bool where + toData + -- ((())) + | false => .list [.list [.list []]] + -- (()()) + | true => .list [.list [], .list []] + +@[simp] +public lemma Bool.toData (d : Bool) : + StrEnc.toData d = match d with + | false => .list [.list [.list []]] + | true => .list [.list [], .list []] := by rfl + +public instance (α : Type*) [StrEnc α] : StrEnc (List α) where + toData l := Data.list (l.map StrEnc.toData) + +@[simp, grind =] +public lemma atPath_toData_list {α : Type*} [StrEnc α] + (x : List α) (i : ℕ) (h_lt : i < x.length) (path : List ℕ) : + (StrEnc.toData x).atPath (i :: path) = (StrEnc.toData x[i]).atPath path := by + simp [Data.atPath, h_lt] + +/-- Encode `Option α` using the empty list for `none` and a singleton list otherwise. -/ +public instance (α : Type) [StrEnc α] : StrEnc (Option α) where + toData o := StrEnc.toData o.toList + +/-- Encode `ℕ` in dyadic, using `true` for `2` and `false` for `1`. -/ +public instance : StrEnc ℕ where + toData n := StrEnc.toData ((dyadic n).map (· == '2')) + +@[simp] +public lemma Nat.toData_zero : + StrEnc.toData 0 = Data.list [] := by simp [StrEnc.toData, dyadic] + +@[simp] +public lemma Nat.toData_one : + StrEnc.toData 1 = StrEnc.toData [false] := by simp [StrEnc.toData, dyadic] + +@[simp] +public lemma Nat.toData_two : + StrEnc.toData 2 = StrEnc.toData [true] := by simp [StrEnc.toData, dyadic] + +@[simp] +public lemma Nat.toData_three : + StrEnc.toData 3 = StrEnc.toData [false, false] := by simp [StrEnc.toData, dyadic]; grind + +/-- Decode a `Data` value as a natural number, mirroring the dyadic encoding used +by the `StrEnc ℕ` instance. Returns `none` if the structure does not match. -/ +public def Data.asNat? : Data → Option ℕ + | .list ds => do + let bits ← ds.mapM (fun + | .list [.list [.list []]] => some false + | .list [.list [], .list []] => some true + | _ => none) + dyadic_inv (bits.map (if · then '2' else '1')) + +@[simp] +public lemma Data.asNat?_nil : Data.asNat? (Data.list []) = some 0 := by + simp [Data.asNat?, dyadic_inv] + +@[simp] +public lemma Data.asNat?_toData (n : ℕ) : Data.asNat? (StrEnc.toData n) = some n := by + sorry + +@[simp] +public lemma Data.asNat?_singleton_false : + Data.asNat? (StrEnc.toData ([false] : List Bool)) = some 1 := by + rw [show (StrEnc.toData ([false] : List Bool) : Data) = StrEnc.toData (1 : ℕ) from + (Nat.toData_one).symm] + exact Data.asNat?_toData 1 + +@[simp] +public lemma Data.asNat?_singleton_true : + Data.asNat? (StrEnc.toData ([true] : List Bool)) = some 2 := by + rw [show (StrEnc.toData ([true] : List Bool) : Data) = StrEnc.toData (2 : ℕ) from + (Nat.toData_two).symm] + exact Data.asNat?_toData 2 + +/-- Encode `Char` through `ℕ` -/ +public instance : StrEnc Char where + toData o := StrEnc.toData o.toNat + +/-- Encode `Fin k` through `ℕ`. +TODO: We might want to use padded encoding if `k` is a power of two. -/ +public instance (k : ℕ) : StrEnc (Fin k) where + toData i := StrEnc.toData i.val + +public instance (k : ℕ) (α : Type*) [StrEnc α] : StrEnc (Fin k → α) where + toData f := StrEnc.toData (List.ofFn f) + +@[simp, grind =] +public lemma atPath_toData_fin {k : ℕ} {α : Type*} [StrEnc α] + (x : Fin k → α) (i : ℕ) (h_lt : i < k) (path : List ℕ) : + (StrEnc.toData x).atPath (i :: path) = (StrEnc.toData (x ⟨i, h_lt⟩)).atPath path := by + simp [StrEnc.toData, h_lt] + +public instance (α : Type*) (β : Type*) [StrEnc α] [StrEnc β] : StrEnc (α × β) where + toData p := Data.list [StrEnc.toData p.1, StrEnc.toData p.2] + +@[simp, grind =] +public lemma atPath_toData_zero_pair {α β : Type*} [StrEnc α] [StrEnc β] + (p : α × β) (path : List ℕ) : + (StrEnc.toData p).atPath (0 :: path) = (StrEnc.toData p.fst).atPath path := by + simp [StrEnc.toData] + +@[simp, grind =] +public lemma atPath_toData_one_pair {α β : Type*} [StrEnc α] [StrEnc β] + (p : α × β) (path : List ℕ) : + (StrEnc.toData p).atPath (1 :: path) = (StrEnc.toData p.snd).atPath path := by + simp [StrEnc.toData] + +/-- `StrEnc` for functions `α → β` where `α` is finite, encoded as the function's + graph: a list of `(a, f a)` pairs. + Not registered as an instance to avoid overlap with `Fin k → α`. + Activate with `letI := StrEnc.ofFunction α β`. -/ +@[reducible, expose] +public def StrEnc.ofFunction (α : Type) (β : Type*) + [Fintype α] [LinearOrder α] [StrEnc α] [StrEnc β] : StrEnc (α → β) where + toData f := StrEnc.toData ((Finset.univ.sort (· ≤ ·)).map fun a => (a, f a)) + +/-- `StrEnc` instance for any `Encodable` type via its encoding to `ℕ`. + Not registered as an instance to avoid overlap with specific encodings + (e.g., `Bool`). Use `attribute [local instance] StrEnc.ofEncodable` or + `letI := StrEnc.ofEncodable α` to activate. -/ +@[reducible] +public def StrEnc.ofEncodable (α : Type) [Encodable α] : StrEnc α where + toData a := StrEnc.toData (Encodable.encode a) + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/DecRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/DecRoutine.lean new file mode 100644 index 0000000000..185c2f20e6 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/DecRoutine.lean @@ -0,0 +1,76 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes +public import Cslib.Computability.Machines.MultiTapeTuring.CopyRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.SuccRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PushRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PopRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.SequentialCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.LoopCombinator + +namespace Turing + +namespace Routines + +def dec₀ : MultiTapeTM 6 (WithSep OneTwo) := + push 1 [];ₜ push 2 [];ₜ + loop 0 (pop 2;ₜ copy 1 2;ₜ succ 1);ₜ + pop 0;ₜ + copy 2 0;ₜ + pop 2;ₜ + pop 1 + + +@[simp] +lemma inner_eval_iter {r : ℕ} {tapes : Fin 3 → List (List OneTwo)} : + (Part.bind · (pop 2;ₜ copy 1 2;ₜ succ 1).eval_list)^[r] (.some tapes) = Part.some ( + if r = 0 then + tapes + else + Function.update (Function.update tapes + 2 ((dya ((dya_inv ((tapes 1).headD [])) + (r - 1))) :: (tapes 2).tail)) + 1 ((dya ((dya_inv ((tapes 1).headD [])) + r)) :: (tapes 1).tail)) := by + induction r with + | zero => simp + | succ r ih => + rw [Function.iterate_succ_apply'] + simp [ih] + grind + +@[simp, grind =] +lemma dec₀_eval_list {tapes : Fin 6 → List (List OneTwo)} : + dec₀.eval_list tapes = .some (Function.update tapes 0 + ((dya ((dya_inv ((tapes 0).headD [])) - 1)) :: (tapes 0).tail)) := by + by_cases h : dya_inv ((tapes 0).head?.getD []) = 0 + <;> simp [dec₀, h] <;> grind + +/-- +A Turing machine that decrements the dyadic value at the head of tape `i`. +If the value is zero already, keeps it at zero. If the tape is empty, pushes zero. +-/ +public def dec {k : ℕ} (i : Fin (k + 6)) + (aux : Fin (k + 6) := ⟨k + 1, by omega⟩) + (h_inj : [i, aux, aux + 1, aux + 2, aux + 3, aux + 4].get.Injective := + by intro x y; grind) : + MultiTapeTM (k + 6) (WithSep OneTwo) := + dec₀.with_tapes [i, aux, aux + 1, aux + 2, aux + 3, aux + 4].get h_inj + +@[simp, grind =] +public theorem dec_eval_list {k : ℕ} (i aux : Fin (k + 6)) + (h_inj : [i, aux, aux + 1, aux + 2, aux + 3, aux + 4].get.Injective) + (tapes : Fin (k + 6) → List (List OneTwo)) : + (dec i aux h_inj).eval_list tapes = .some (Function.update tapes i + ((dya ((dya_inv ((tapes i).headD [])) - 1)) :: (tapes i).tail)) := by + simpa [dec] using apply_updates_function_update h_inj + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/DuplicateRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/DuplicateRoutine.lean new file mode 100644 index 0000000000..0e9e991dd9 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/DuplicateRoutine.lean @@ -0,0 +1,53 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes +public import Cslib.Computability.Machines.MultiTapeTuring.CopyRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PopRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.SequentialCombinator + +namespace Turing + +namespace Routines + +variable [Inhabited α] [Fintype α] + +def duplicate₀ : MultiTapeTM 2 (WithSep α) := copy 0 1;ₜ copy 1 0;ₜ pop 1 + +@[simp] +lemma duplicate₀_eval_list {tapes : Fin 2 → List (List α)} : + duplicate₀.eval_list tapes = .some (Function.update tapes 0 + (((tapes 0).headD []) :: (tapes 0))) := by + simp [duplicate₀] + grind + +/-- +A Turing machine that duplicates the head of tape `i` (or pushes the empty word +if the tape is empty. +-/ +public def duplicate {k : ℕ} (i : Fin k.succ) + (aux : Fin k.succ := ⟨k, by omega⟩) + (h_inj : [i, aux].get.Injective := by intro x y; grind) : + MultiTapeTM k.succ (WithSep α) := + duplicate₀.with_tapes [i, aux].get h_inj + +@[simp, grind =] +public theorem duplicate_eval_list {k : ℕ} {i : Fin k.succ} + (aux : Fin k.succ := ⟨k, by omega⟩) + (h_inj : [i, aux].get.Injective) + {tapes : Fin k.succ → List (List OneTwo)} : + (duplicate i aux h_inj).eval_list tapes = Part.some (Function.update tapes i + (((tapes i).headD []) :: (tapes i))) := by + simp [duplicate] + grind + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Dyadic.lean b/Cslib/Computability/Machines/MultiTapeTuring/Dyadic.lean new file mode 100644 index 0000000000..25f3a2e5ee --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Dyadic.lean @@ -0,0 +1,72 @@ +/- +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.MultiTapeTuring.Basic +public import Mathlib.Data.FinEnum + +namespace Turing + +public instance : Fintype Char where + elems := (Finset.range 0x110000).attach.image fun ⟨n, _⟩ => + if h : n.isValidChar then Char.ofNatAux n h else default + complete c := by + have hN : c.val.toNat < 0x110000 := by + rcases c.valid with h | ⟨_, h⟩ + · exact Nat.lt_trans h (by decide) + · exact h + rw [Finset.mem_image] + refine ⟨⟨c.val.toNat, Finset.mem_range.mpr hN⟩, Finset.mem_attach _ _, ?_⟩ + have hv : c.val.toNat.isValidChar := c.valid + simp only [hv, ↓reduceDIte] + apply Char.ext + change (Char.ofNatAux c.val.toNat hv).val = c.val + cases c with | _ val _ => cases val with | _ bv => simp [Char.ofNatAux] + +/-- Dyadic encoding of natural numbers. -/ +@[expose] +public def dyadic (n : ℕ) : List Char := + if n = 0 then [] + else if Even n then + dyadic (n / 2 - 1) ++ ['2'] + else + dyadic ((n - 1) / 2) ++ ['1'] + +/-- Dyadic decoding of natural numbers. -/ +@[expose] +public def dyadic_inv (l : List Char) : Option ℕ := + l.foldlM (fun acc c => + if c = '1' then some (2 * acc + 1) + else if c = '2' then some (2 * acc + 2) + else none) 0 + +@[simp, grind =] +public lemma dyadic_inv_zero : dyadic_inv [] = .some 0 := by + unfold dyadic_inv; rfl + +@[simp, grind =] +public lemma dyadic_inv_dyadic (n : ℕ) : dyadic_inv (dyadic n) = n := by + induction n using Nat.strongRecOn with + | _ n ih => + unfold dyadic + split + · subst_vars; simp [dyadic_inv] + · next h_nz => + split <;> rename_i h_parity <;> + simp only [dyadic_inv, List.foldlM_append, Option.bind_eq_bind] <;> + rw [show List.foldlM _ 0 _ = dyadic_inv (dyadic _) from rfl, + ih _ (by omega)] <;> + simp + · obtain ⟨m, hm⟩ := h_parity; omega + · obtain ⟨m, hm⟩ := Nat.not_even_iff_odd.mp h_parity; omega + +public lemma dyadic_mem_chars {c : Char} {n : ℕ} (h : c ∈ dyadic n) : + c = '1' ∨ c = '2' := by + induction n using Nat.strongRecOn with + | _ n ih => grind [dyadic] + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/EqualRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/EqualRoutine.lean new file mode 100644 index 0000000000..b5c3d88b41 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/EqualRoutine.lean @@ -0,0 +1,65 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +import Mathlib.Logic.Function.Basic + +namespace Turing + +namespace Routines + +/-- +A 3-tape Turing machine that pushes the new word "1" +to the third tape if the first words on the first and second tape are the same +and otherwise pushes the empty word to the third tape. +If one of the first two tapes is empty, uses the empty word for comparison. +-/ +def eq₀ : MultiTapeTM 3 (WithSep OneTwo) where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp] +theorem eq₀_eval_list {tapes : Fin 3 → List (List OneTwo)} : + eq₀.eval_list tapes = + Part.some (Function.update tapes 2 ((if (tapes 0).headD [] = (tapes 1).headD [] then + [.one] + else + []) :: (tapes 2))) := by + sorry + +/-- +A Turing machine that pushes the new word "1" +to tape `t` if the first words on tape `q` and tape `s` are the same +and otherwise pushes the empty word to tape `t`. +If one of the tapes `q` or `s` are empty, uses the empty word for comparison. +-/ +public def eq {k : ℕ} (q s t : Fin k) + (h_inj : [q, s, t].get.Injective := by intro x y; grind) : + MultiTapeTM k (WithSep OneTwo) := + eq₀.with_tapes [q, s, t].get h_inj + +@[grind =] +public theorem eq_eval_list {k : ℕ} {q s t : Fin k} + (h_inj : [q, s, t].get.Injective) + {tapes : Fin k → List (List OneTwo)} : + (eq q s t).eval_list tapes = + Part.some (Function.update tapes t ((if (tapes q).headD [] = (tapes s).headD [] then + [.one] + else + []) :: (tapes t))) := by + simp [eq] + grind + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/GraphReachability.lean b/Cslib/Computability/Machines/MultiTapeTuring/GraphReachability.lean new file mode 100644 index 0000000000..508491caab --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/GraphReachability.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +import Cslib.Foundations.Data.BiTape +import Cslib.Foundations.Data.RelatesInSteps + +public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.HeadStats + +-- TODO create a "common file" +import Cslib.Computability.Machines.SingleTapeTuring.Basic + +namespace Turing + + +-- This is an attempt at proving Savitch's theorem. We start by stating a generic +-- space-efficient graph reachability algorithm. + +/- + +General idea, assume distance is power of two: + +def reachable(a, b, t, r): + if t = 0: + return r(a, b) + else: + for c in vertices: + if reachable(a, c, t - 1, r) and reachable(c, b, t - 1, r): + return True + return False + +Until we have a generic mechanism for recursion, let's translate this into a program that +uses "goto", and every variable is a stack: + +def reachable(a, b, t, r): + terminate = 0 + result = 0 + section = [0] + while !terminate: + match section.pop() + | 0 => + if t = 0: + result = r(a, b) + terminate = 1 + section.push(7) + else: + section.push(1) + | 1 => + c.push(0) + section.push(2) + | 2 => + if c.top() = num_vertices: + section.push(6) + else: + a.push(a.top()) + b.push(c.top()) + section.push(0) + t.push(t.top() - 1) + section.push(3) + | 3 => + section.push(4) + + + +-/ + + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/HeadStats.lean b/Cslib/Computability/Machines/MultiTapeTuring/HeadStats.lean new file mode 100644 index 0000000000..3538f10bcb --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/HeadStats.lean @@ -0,0 +1,68 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.TapeExtension + + +namespace Turing + +variable [Inhabited Symbol] [Fintype Symbol] + +variable {k : ℕ} + +/-- Statistics on the tape head movements. -/ +public structure HeadStats where + /-- The minimal (left-most) position of the head during the computation, + relative to the starting position. -/ + min : ℤ + /-- The maximal (right-most) position of the head during the computation, + relative to the starting position. -/ + max : ℤ + /-- The final position of the head after the computation, relative to the + starting position. -/ + final : ℤ + h_bounds : min ≤ final ∧ final ≤ max ∧ min ≤ 0 ∧ 0 ≤ max + +/-- The space required. -/ +public def HeadStats.space (hs : HeadStats) : ℕ := + (1 + hs.max - hs.min).toNat -- TODO we know it is nonnegative, is there a way to make use of that? + + +/-- Compute the head statistics for a turing machine starting with a certain tape configuration. -/ +public def headStats (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : + Part (Fin k → HeadStats) := sorry + +/-- Execute a Turing machine and also compute head statistics. -/ +public def MultiTapeTM.evalWithStats (tm : MultiTapeTM k Symbol) (tapes : Fin k → BiTape Symbol) : + Part ((Fin k → BiTape Symbol) × (Fin k → HeadStats)) := sorry + +-- move this somewhere else +def seq (tm₁ tm₂ : MultiTapeTM k Symbol) : MultiTapeTM k Symbol := sorry + +def seq_combine_stats (stats₁ stats₂ : Fin k → HeadStats) : Fin k → HeadStats := + fun i => match (stats₁ i, stats₂ i) with + | (⟨min₁, max₁, final₁, h₁⟩, ⟨min₂, max₂, final₂, h₂⟩) => + ⟨min min₁ (min₂ + final₁), + max max₁ (max₂ + final₁), + final₁ + final₂, + by omega⟩ + +lemma seq_evalWithStats (tm₁ tm₂ : MultiTapeTM k Symbol) + (tapes : Fin k → BiTape Symbol) (i : Fin k) : + (seq tm₁ tm₂).evalWithStats tapes = do + let (tapes', stats₁) ← tm₁.evalWithStats tapes + let (tapes'', stats₂) ← tm₂.evalWithStats tapes' + return (tapes'', seq_combine_stats stats₁ stats₂) := by sorry + +-- Next step: relate space requirements and head stats. + +theorem stats_and_space (tm : MultiTapeTM k Symbol) (tapes tapes' : Fin k → BiTape Symbol) (s : ℕ) : + (∃ t, tm.TransformsTapesInTimeAndSpace tapes tapes' t s) ↔ + ∃ hs, (∑ i, (hs i).space) ≤ s ∧ tm.evalWithStats tapes = .some (tapes', hs) := by sorry +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/IsZeroRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/IsZeroRoutine.lean new file mode 100644 index 0000000000..bceed63f55 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/IsZeroRoutine.lean @@ -0,0 +1,35 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.PushRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PopRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.SequentialCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.IteCombinator + +namespace Turing + +variable {k : ℕ} + +namespace Routines + +/-- +A Turing machine that computes the logical negation: It replaces an empty (or non-existing) head +on tape `i` by the word "1" and everything else by the empty word. -/ +public def isZero (i : Fin k) := ite_num i (pop i;ₜ push i []) (pop i;ₜ push i [OneTwo.one]) + +@[simp, grind =] +public theorem isZero_eval_list {i : Fin k} {tapes : Fin k → List (List OneTwo)} : + (isZero i).eval_list tapes = .some (Function.update tapes i ( + (if (tapes i).headD [] = [] then [OneTwo.one] else []) :: (tapes i).tail)) := by + simp [isZero] + grind + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/IteCombinator.lean b/Cslib/Computability/Machines/MultiTapeTuring/IteCombinator.lean new file mode 100644 index 0000000000..ada534e027 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/IteCombinator.lean @@ -0,0 +1,40 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding + +namespace Turing + +namespace Routines + +variable [Inhabited α] [Fintype α] +variable {k : ℕ} + +/-- +A Turing machine combinator that runs `tm₁` if the first word on tape `i` exists and is non-empty, +otherwise it runs `tm₂`. -/ +public def ite_num (i : Fin k) (tm₁ tm₂ : MultiTapeTM k (WithSep α)) : + MultiTapeTM k (WithSep α) where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp, grind =] +public theorem ite_eval_list + {i : Fin k} + {tm₁ tm₂ : MultiTapeTM k (WithSep α)} + {tapes : Fin k → List (List α)} : + (ite_num i tm₁ tm₂).eval_list tapes = + if (tapes i).headD [] = [] then tm₂.eval_list tapes else tm₁.eval_list tapes := by + sorry + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/ListEncoding.lean b/Cslib/Computability/Machines/MultiTapeTuring/ListEncoding.lean new file mode 100644 index 0000000000..9f1ce418ad --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/ListEncoding.lean @@ -0,0 +1,221 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +import Mathlib.Tactic.DeriveFintype + +namespace Turing + +variable {Symbol : Type} +variable [Inhabited Symbol] [Fintype Symbol] + +/-- +An alphabet that contains exactly two symbols, 1 and 2. +TODO use an embedding or something else that is more flexible +-/ +public inductive OneTwo where + | one + | two +deriving DecidableEq, Inhabited, Fintype + + +/-- An alphabet for list encoding -/ +public inductive WithSep (Symbol : Type) where + | ofChar (c : Symbol) + | comma + -- TODO need to decide if we want to encode lists with parentheses or not. + -- Is annoying when pushing and popping from lists, but can be useful to avoid + -- running "off the tape" + -- | lParen + -- | rParen +deriving Fintype, DecidableEq, Inhabited + +/-- A list of words is transformed by appending a comma after each word and concatenating. +Note that the comma is not only a separator but also appears as the final character +of the resulting string (if the list is non-empty). -/ +public def listToString (ls : List (List Symbol)) : List (WithSep Symbol) := + (ls.map (fun w : List Symbol => (w.map .ofChar) ++ [.comma])).flatten + +/-- Turn an encoded list back to a string, if possible. This is the inverse of +`listToString`. -/ +public def stringToList (s : List (Option (WithSep Symbol))) : Option (List (List Symbol)) := + s.foldr (fun c acc => + match c with + | none => none + | some .comma => acc.map ([] :: ·) + | some (.ofChar c) => acc.bind (fun ws => + match ws with + | [] => none + | w :: rest => some ((c :: w) :: rest))) + (some []) + +/-- Encodes a list of words into a tape. -/ +public def listToTape (ls : List (List Symbol)) : BiTape (WithSep Symbol) := + BiTape.mk₁ (listToString ls) + +/-- Only tapes where the head is at the left end are accepted. -/ +public def tapeToList (tape : BiTape (WithSep Symbol)) : Option (List (List Symbol)) := + match (tape.left.toList, tape.head) with + | ([], c) => stringToList (c :: tape.right.toList) + | _ => none + +/-- Turn a tuple of tapes created by `listToTape` back to a tuple of lists, if possible. -/ +public def tapesToLists (tapes : Fin k → BiTape (WithSep Symbol)) : + Option (Fin k → List (List Symbol)) := + if h : ∀ i, (tapeToList (tapes i)).isSome then + some (fun i => (tapeToList (tapes i)).get (h i)) + else + none + +/-- The Turing machine `tm` transforms the list-encoded tapes `tapes` into the list-encoded +tapes `tapes'`. -/ +public def MultiTapeTM.TransformsLists + (tm : MultiTapeTM k (WithSep Symbol)) + (tapes tapes' : Fin k → List (List Symbol)) : Prop := + tm.TransformsTapes (listToTape ∘ tapes) (listToTape ∘ tapes') + +/-- The Turing machine `tm` halts starting with list-encoded tapes `tapes` +and also always outputs properly list-encoded tapes. -/ +public def MultiTapeTM.HaltsOnLists + (tm : MultiTapeTM k (WithSep Symbol)) + (tapes : Fin k → List (List Symbol)) : Prop := + ∃ tapes', tm.TransformsLists tapes tapes' + +/-- Execute the Turing machine `tm` on the list-encoded tapes `tapes`. -/ +public def MultiTapeTM.eval_list + (tm : MultiTapeTM k (WithSep Symbol)) + (tapes : Fin k → List (List Symbol)) : + Part (Fin k → List (List Symbol)) := + (tm.eval (listToTape ∘ tapes)).bind fun tapes => tapesToLists tapes + +@[simp] +public theorem MultiTapeTM.HaltsOnLists_of_eval_list + {tm : MultiTapeTM k (WithSep Symbol)} + {tapes : Fin k → List (List Symbol)} + (h_dom : (tm.eval_list tapes).Dom) : + tm.HaltsOnLists tapes := by + sorry + +@[simp] +public lemma MultiTapeTM.eval_list_dom_of_halts_on_lists + {tm : MultiTapeTM k (WithSep Symbol)} + {tapes : Fin k → List (List Symbol)} + (h_halts : tm.HaltsOnLists tapes) : + (tm.eval_list tapes).Dom := by + sorry + +/-- Execute the Turing machine `tm` knowing that it always halts, thus yielding a total function +on the tapes. -/ +@[simp] +public def MultiTapeTM.eval_list_tot + (tm : MultiTapeTM k (WithSep Symbol)) + (h_alwaysHalts : ∀ tapes, tm.HaltsOnLists tapes) + (tapes : Fin k → List (List Symbol)) : + Fin k → List (List Symbol) := + (tm.eval_list tapes).get (tm.eval_list_dom_of_halts_on_lists (h_alwaysHalts tapes)) + +@[simp, grind =] +public theorem MultiTapeTM.extend_eval_list + {k₁ k₂ : ℕ} {h_le : k₁ ≤ k₂} + {tm : MultiTapeTM k₁ (WithSep Symbol)} + {tapes : Fin k₂ → List (List Symbol)} : + (tm.extend h_le).eval_list tapes = + (tm.eval_list (tapes ⟨·, by omega⟩)).map (fun tapes' => + fun i : Fin k₂ => if h : i.val < k₁ then tapes' ⟨i, h⟩ else tapes i) := by + sorry + +@[simp, grind =] +public theorem MultiTapeTM.permute_tapes_eval_list + (tm : MultiTapeTM k (WithSep Symbol)) (σ : Equiv.Perm (Fin k)) + (tapes : Fin k → List (List Symbol)) : + (tm.permute_tapes σ).eval_list tapes = + (tm.eval_list (tapes ∘ σ)).map (fun tapes' => tapes' ∘ σ.symm) := by + sorry + +@[simp, grind =] +public theorem MultiTapeTM.with_tapes_eval_list + {k₁ k₂ : ℕ} + {tm : MultiTapeTM k₁ (WithSep Symbol)} {f : Fin k₁ → Fin k₂} {h_inj : f.Injective} + {tapes : Fin k₂ → List (List Symbol)} : + (tm.with_tapes f h_inj).eval_list tapes = + (tm.eval_list (tapes ∘ f)).map + (fun tapes' => fun t => apply_updates tapes tapes' f t) := by + sorry + +-- def MultiTapeTM.TransformsListsWithStats +-- (tm : MultiTapeTM k (WithSep Symbol)) +-- (tapes : Fin k → List (List Symbol)) +-- (ts : (Fin k → List (List Symbol)) × (Fin k → HeadStats)) : Prop := +-- tm.evalWithStats (listToTape ∘ tapes) = .some (listToTape ∘ ts.1, ts.2) + +-- /-- +-- Evaluate the Turing machine `tm` on the list-encoded tapes `tapes` and also return the head +-- statistics of the computation. +-- -/ +-- public noncomputable def MultiTapeTM.evalWithStats_list +-- (tm : MultiTapeTM k (WithSep Symbol)) +-- (tapes : Fin k → List (List Symbol)) : +-- Part ((Fin k → List (List Symbol)) × (Fin k → HeadStats)) := +-- ⟨∃ ts, tm.TransformsListsWithStats tapes ts, fun h => h.choose⟩ + +-- TODO for machines running on lists, we can actually have more precise head stats: +-- we know (and should enforce) that the head never moves to the right of the rightmost symbol +-- and always starts and ends on the leftmost symbol (and if the tape is empty, it never moves +-- to the right of the starting position). +-- So the minimal information we need is (per tape) the amount of symbols that were used beyond +-- the max of the ones in the initial and final configuration. +-- TODO it also makes sense to allow upper bounds on that. + +/-- +The Turing machine `tm` computes a total function on lists and this uniquely +determined function is `f`. +-/ +public def MultiTapeTM.computes + (tm : MultiTapeTM k (WithSep Symbol)) + (f : (Fin k → List (List Symbol)) → (Fin k → List (List Symbol))) : Prop := + ∀ tapes, tm.eval_list tapes = .some (f tapes) + +public theorem MultiTapeTM.eval_of_computes + {Symbol : Type} + [Fintype Symbol] + {tm : MultiTapeTM k (WithSep Symbol)} + {f : (Fin k → List (List Symbol)) → (Fin k → List (List Symbol))} + (h_computes : tm.computes f) + {tapes : Fin k → List (List Symbol)} : + tm.eval_list tapes = .some (f tapes) := by + specialize h_computes tapes + simpa [MultiTapeTM.computes] using h_computes + + +/-- Dyadic encoding of natural numbers. -/ +public def dya (n : ℕ) : List OneTwo := + if n = 0 then [] + else if Even n then + dya (n / 2 - 1) ++ [.two] + else + dya ((n - 1) / 2) ++ [.one] + +/-- Dyadic decoding of natural numbers. -/ +public def dya_inv : List OneTwo → ℕ := sorry + +@[simp, grind =] +public lemma dya_zero : dya 0 = [] := by simp [dya] + +@[simp, grind =] +public lemma dya_inv_zero : dya_inv [] = 0 := by + sorry + +@[simp, grind =] +public lemma dya_inv_dya (n : ℕ) : dya_inv (dya n) = n := by sorry + +@[simp, grind =] +public lemma dya_dya_inv (w : List OneTwo) : dya (dya_inv w) = w := by sorry + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/LoopCombinator.lean b/Cslib/Computability/Machines/MultiTapeTuring/LoopCombinator.lean new file mode 100644 index 0000000000..217f62a3a8 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/LoopCombinator.lean @@ -0,0 +1,59 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding + +namespace Turing + +namespace Routines + +variable {k : ℕ} + +/-- +A Turing machine that executes `tm` a number of times as given by the first word on tape `i`. +If tape `i` is empty, do not execute the TM. +Note that the iteration counter is not directly available to `tm`. -/ +public def loop (i : Fin k) + (tm : MultiTapeTM k (WithSep OneTwo)) : MultiTapeTM (k + 3) (WithSep OneTwo) := + sorry + -- let target : Fin (k + (aux + 3)) := ⟨aux, by omega⟩ + -- let counter : Fin (k + (aux + 3)) := ⟨aux + 1, by omega⟩ + -- let cond : Fin (k + (aux + 3)) := ⟨aux + 2, by omega⟩ + -- (copy (k := k + (aux + 3)) i target (h_neq := by grind) <;> + -- push counter [] <;> + -- neq target counter cond (by grind) (by grind) (by grind) <;> + -- doWhile cond ( + -- pop cond <;> + -- tm.toMultiTapeTM <;> + -- succ counter <;> + -- neq target counter cond (by grind) (by grind) (by grind)) <;> + -- pop cond <;> + -- pop counter <;> + -- pop target).set_aux_tapes (aux + 3) + + +@[simp] +public theorem loop_eval_list {i : Fin k} + {tm : MultiTapeTM k (WithSep OneTwo)} + {tapes : Fin (k + 3) → List (List OneTwo)} : + (loop i tm).eval_list tapes = + (((Part.bind · tm.eval_list)^[dya_inv ((tapes ⟨i, by omega⟩).headD [])] + (Part.some (tapes_take tapes k (by omega))))).map + fun tapes' => tapes_extend_by tapes' tapes := by + sorry + +@[simp] +public theorem loop_halts_of_halts {i : Fin k} + {tm : MultiTapeTM k (WithSep OneTwo)} + (h_halts : ∀ tapes, tm.HaltsOnLists tapes) : + ∀ tapes, (loop i tm).HaltsOnLists tapes := by + sorry + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/MoveRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/MoveRoutine.lean new file mode 100644 index 0000000000..443eb44a54 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/MoveRoutine.lean @@ -0,0 +1,102 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.MultiTapeTuring.Basic + +namespace Turing + +namespace Routines + +variable [Inhabited α] [Fintype α] + +-- /-- A 1-tape Turing machine that moves its head in a given direction +-- once and then halts. -/ +-- public def move (dir : Dir) : MultiTapeTM 1 α where +-- Λ := PUnit +-- q₀ := 0 +-- M _ syms := (fun i => ⟨syms i, some dir⟩, none) + +-- @[simp] +-- public lemma move_eval (tape : BiTape α) (dir : Turing.Dir) : +-- (move dir).eval (fun _ => tape) = .some (fun _ => tape.move dir) := by +-- sorry +-- rw [MultiTapeTM.eval_iff_exists_steps_iter_eq_some] +-- use 1 +-- rfl + +-- /-- A 1-tape Turing machine that moves its head in a given direction until a condition +-- on the read symbol is met. -/ +-- public def move_until (dir : Turing.Dir) (cond : (Option α) → Bool) : MultiTapeTM 1 α where +-- Λ := PUnit +-- q₀ := PUnit.unit +-- M q syms := match cond (syms 0) with +-- | false => (fun _ => ⟨syms 0, some dir⟩, some q) +-- | true => (fun _ => ⟨syms 0, none⟩, none) + +-- lemma move_until_step_cond_false +-- {tape : BiTape α} +-- {stop_condition : Option α → Bool} +-- (h_neg_stop : ¬ stop_condition tape.head) : +-- (move_until .right stop_condition).step +-- ⟨some (move_until .right stop_condition).q₀, (fun _ => tape)⟩ = +-- some ⟨some (move_until .right stop_condition).q₀, (fun _ => tape.move .right)⟩ := by +-- simp [move_until, h_neg_stop, BiTape.optionMove, MultiTapeTM.step] + +-- lemma move_until_step_cond_true +-- {tape : BiTape α} +-- {stop_condition : Option α → Bool} +-- (h_neg_stop : stop_condition tape.head) : +-- (move_until .right stop_condition).step +-- ⟨some (move_until .right stop_condition).q₀, (fun _ => tape)⟩ = +-- some ⟨none, (fun _ => tape)⟩ := by +-- simp [move_until, h_neg_stop, BiTape.optionMove, MultiTapeTM.step] + +-- public theorem move_until.right_semantics +-- (tape : BiTape α) +-- (stop_condition : Option α → Bool) +-- (h_stop : ∃ n : ℕ, stop_condition (tape.nth n)) : +-- (move_until .right stop_condition).eval (fun _ => tape) = +-- .some (fun _ => tape.move_int (Nat.find h_stop)) := by +-- rw [MultiTapeTM.eval_iff_exists_steps_iter_eq_some] +-- let n := Nat.find h_stop +-- use n.succ +-- have h_not_stop_of_lt : ∀ k < n, ¬ stop_condition (tape.move_int k).head := by +-- intro k hk +-- simp [Nat.find_min h_stop hk] +-- have h_iter : ∀ k < n, (Option.bind · (move_until .right stop_condition).step)^[k] +-- (some ⟨some (move_until .right stop_condition).q₀, fun _ => tape⟩) = +-- some ⟨some (move_until .right stop_condition).q₀, fun _ => tape.move_int k⟩ := by +-- intro k hk +-- induction k with +-- | zero => +-- simp [BiTape.move_int] +-- | succ k ih => +-- have hk' : k < n := Nat.lt_of_succ_lt hk +-- rw [Function.iterate_succ_apply', ih hk'] +-- simp only [Option.bind_some, move_until_step_cond_false (h_not_stop_of_lt k hk')] +-- simp [BiTape.move, ← BiTape.move_int_one_eq_move_right, BiTape.move_int_move_int] +-- have h_n_eq : n = Nat.find h_stop := by grind +-- by_cases h_n_zero : n = 0 +-- · have h_stop_cond : stop_condition (tape.head) := by simp_all [n] +-- let h_step := move_until_step_cond_true h_stop_cond +-- simp [h_step, ← h_n_eq, h_n_zero] +-- · obtain ⟨n', h_n'_eq_n_succ⟩ := Nat.exists_eq_add_one_of_ne_zero h_n_zero +-- rw [h_n'_eq_n_succ, Function.iterate_succ_apply', Function.iterate_succ_apply'] +-- have h_n'_lt_n : n' < n := by omega +-- simp only [MultiTapeTM.initCfgTapes, MultiTapeTM.haltCfgTapes] +-- rw [h_iter n' h_n'_lt_n] +-- simp only [Option.bind_some, move_until_step_cond_false (h_not_stop_of_lt n' h_n'_lt_n)] +-- simp only [BiTape.move, ← BiTape.move_int_one_eq_move_right, BiTape.move_int_move_int] +-- rw [show (n' : ℤ) + 1 = n by omega] +-- have h_n_stop : stop_condition ((tape.move_int n).head) := by +-- simpa [n] using Nat.find_spec h_stop +-- simpa using move_until_step_cond_true h_n_stop + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/MulRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/MulRoutine.lean new file mode 100644 index 0000000000..67b63071b3 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/MulRoutine.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.AddRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.PushRoutine +public import Cslib.Computability.Machines.MultiTapeTuring.LoopCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.SequentialCombinator +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +namespace Turing + +variable {k : ℕ} + +namespace Routines + +-- Multiplies the heads of 0 and 1 and stores the result in 2. +def mul₀ : MultiTapeTM 9 (WithSep OneTwo) := + push 2 [];ₜ loop 0 (add_assign 1 2 3) + +@[simp] +lemma add_assign_iter {i j aux : Fin (k + 6)} {r : ℕ} + (h_inj : [i, j, aux, aux + 1, aux + 2, aux + 3].get.Injective) + {tapes : Fin (k + 6) → List (List OneTwo)} : + (Part.bind · (add_assign i j aux h_inj).eval_list)^[r] (.some tapes) = + Part.some (Function.update tapes j ( + if r = 0 then + tapes j + else + (dya ((dya_inv ((tapes j).headD [])) + r * (dya_inv ((tapes i).headD [])))) :: + (tapes j).tail)) := by + induction r with + | zero => simp + | succ r ih => + rw [Function.iterate_succ_apply'] + simp only [ih, Part.bind_some] + rw [add_assign_eval_list] + have h_neq : i ≠ j := Function.Injective.ne h_inj (a₁ := 0) (a₂ := 1) (by grind) + simp + grind + +@[simp] +theorem mul₀_eval_list {tapes : Fin 9 → List (List OneTwo)} : + mul₀.eval_list tapes = .some + (Function.update tapes 2 ( + (dya (dya_inv ((tapes 0).headD []) * dya_inv ((tapes 1).headD [])) :: (tapes 2)))) := by + by_cases h_zero: dya_inv ((tapes 0).head?.getD []) = 0 + <;> simp [mul₀, h_zero] <;> grind + +/-- +A Turing machine that multiplies the heads of tapes i and j and pushes the result to tape l. +If tapes are empty, their heads are assumed to be zero. +-/ +public def mul + (i j l : Fin (k + 9)) + (aux : Fin (k + 9) := ⟨k + 3, by omega⟩) + (h_inj : [i, j, l, aux, aux + 1, aux + 2, aux + 3, aux + 4, aux + 5].get.Injective := by decide) : + MultiTapeTM (k + 9) (WithSep OneTwo) := + mul₀.with_tapes [i, j, l, aux, aux + 1, aux + 2, aux + 3, aux + 4, aux + 5].get h_inj + +@[simp, grind =] +public theorem mul_eval_list (i j l aux : Fin (k + 9)) + {h_inj : [i, j, l, aux, aux + 1, aux + 2, aux + 3, aux + 4, aux + 5].get.Injective} + {tapes : Fin (k + 9) → List (List OneTwo)} : + (mul i j l aux h_inj).eval_list tapes = + .some (Function.update tapes l ( + (dya (dya_inv ((tapes i).headD []) * dya_inv ((tapes j).headD [])) :: (tapes l)))) := by + simpa [mul] using apply_updates_function_update h_inj + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/PopRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/PopRoutine.lean new file mode 100644 index 0000000000..a18b72b962 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/PopRoutine.lean @@ -0,0 +1,45 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +namespace Turing + +namespace Routines + +variable [Inhabited α] [Fintype α] + +def pop₁ : MultiTapeTM 1 (WithSep α) where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp] +lemma pop₁_eval_list {tapes : Fin 1 → List (List α)} : + pop₁.eval_list tapes = .some (Function.update tapes 0 (tapes 0).tail) := by + sorry + +/-- +A Turing machine that removes the first word on tape `i`. If the tape is empty, does nothing. +-/ +public def pop {k : ℕ} (i : Fin k) : MultiTapeTM k (WithSep α) := + pop₁.with_tapes [i].get (by intro x y; grind) + +@[simp, grind =] +public theorem pop_eval_list {k : ℕ} {i : Fin k} + {tapes : Fin k → List (List α)} : + (pop i).eval_list tapes = .some (Function.update tapes i (tapes i).tail) := by + have h_inj : [i].get.Injective := by intro x y; grind + simp_all [pop] + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/PushRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/PushRoutine.lean new file mode 100644 index 0000000000..d6c0bac784 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/PushRoutine.lean @@ -0,0 +1,46 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +namespace Turing + +namespace Routines + +variable [Inhabited α] [Fintype α] + +def push₁ (w : List α) : MultiTapeTM 1 (WithSep α) where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp] +lemma push₁_eval_list {w : List α} {tapes : Fin 1 → List (List α)} : + (push₁ w).eval_list tapes = .some (Function.update tapes 0 (w :: (tapes 0))) := by + sorry + +/-- +A Turing machine that pushes the word `w` to tape `i`. +-/ +public def push {k : ℕ} (i : Fin k) (w : List α) : MultiTapeTM k (WithSep α) := + (push₁ w).with_tapes [i].get (by intro x y; grind) + +@[simp, grind =] +public theorem push_eval_list {k : ℕ} + {i : Fin k} {w : List α} {tapes : Fin k → List (List α)} : + (push i w).eval_list tapes = + .some (Function.update tapes i (w :: (tapes i))) := by + have h_inj : [i].get.Injective := by intro x y; grind + simp_all [push] + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Boolean.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Boolean.lean new file mode 100644 index 0000000000..ba7f88aa40 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Boolean.lean @@ -0,0 +1,70 @@ +/- +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.MultiTapeTuring.Routines.CaseDispatch +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.ListOps +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed + +namespace Turing +namespace Routines + + +-- ═══════════════════════════════════════════════════════════════════════════ +-- Boolean operations +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- TODO document -/ +public def combineOrUpdate {k : ℕ} (j : Fin k) : + MultiTapeTM k Char := ite_list_head j true + (popList j;ₜ popList j;ₜ pushList (StrEnc.toData true) j) + noop + +@[simp] +public lemma combineOrUpdate.computes_fun {k : ℕ} {j : Fin k} : + computes_function_update (combineOrUpdate j) (fun (ls : List Bool) => + (ls.head? == some true || ls[1]? == some true) :: ls.tail.tail) j := by + sorry + +-- @[simp] +-- public lemma combineOr_eval_struct {k : ℕ} +-- (in₁ in₂ out : Fin k) +-- (h_inj : [in₁, in₂, out].get.Injective) +-- {views : Fin k → TapeView} : +-- (combineOr in₁ in₂ out h_inj).eval_struct views = some +-- (match (views i).popList with +-- | some (b_data, vi') => +-- let views' := Function.update views i vi' +-- if b_data = StrEnc.toData true then +-- match (views' j).popList with +-- | some (_, vj') => +-- Function.update (Function.update views' i vi') +-- j ((vj').pushList (StrEnc.toData true)) +-- | none => views' +-- else views' +-- | none => views) := by sorry + +/-- Negate a Bool value on tape `j`. + Pops the first element from tape `j` and pushes its negation. -/ +public def negateBool {k : ℕ} (j : Fin k) : MultiTapeTM k Char := + case_popList_num j + [-- false (0) → push true (1) + pushList (StrEnc.toData true) j, + -- true (1) → push false (0) + pushList (StrEnc.toData false) j] + +@[simp, grind <=] +public lemma negateBool.computes_head_update {k : ℕ} {i : Fin k} : + computes_function_head_update (negateBool i) Bool.not i := by + sorry + +grind_pattern negateBool.computes_head_update => negateBool i + + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/CaseDispatch.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/CaseDispatch.lean new file mode 100644 index 0000000000..9706c28da0 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/CaseDispatch.lean @@ -0,0 +1,68 @@ +/- +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.MultiTapeTuring.StructuralMachines +public import Cslib.Computability.Machines.MultiTapeTuring.TapeView +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Navigation +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Ite + +namespace Turing +namespace Routines + +-- ═══════════════════════════════════════════════════════════════════════════ +-- Case dispatch +-- ═══════════════════════════════════════════════════════════════════════════ + + +/-- Dispatch on the numeric value of an encoding. + Reads the number `n` and runs `branches[n]`. + The head stays at the start of the encoding. -/ +public def case_nat {k : ℕ} (i : Fin k) + (branches : List (MultiTapeTM k Char)) : MultiTapeTM k Char := sorry + +/-- `case_nat i branches` dispatches on the numeric value at the current position +of tape `i`. If `(views i).current = StrEnc.toData n` and `n < branches.length`, runs +`branches[n]`. Otherwise (tape empty, not a num, or out of range), does nothing. -/ +@[simp] +public lemma case_nat_eval_struct {k : ℕ} {i : Fin k} + {branches : List (MultiTapeTM k Char)} + {views : Fin k → TapeView} : + (case_nat i branches).eval_struct views = + match Data.asNat? (views i).current with + | some n => + if h : n < branches.length then branches[n].eval_struct views + else some views + | none => some views := by sorry + +/-- Dispatch on the numeric value of the first element of a list. + Pops the first element from the list on tape `i`. If it is `Data.num n` + and `n < branches.length`, runs `branches[n]` on the updated views + (with the element removed). If the pop fails, the element is not a number, + or the index is out of range, leaves the tape unmodified. -/ +public def case_popList_num {k : ℕ} (i : Fin k) + (branches : List (MultiTapeTM k Char)) : MultiTapeTM k Char := sorry + +/-- Runs `then_branch` if tape `i` points at a list whose head is `v`, otherwise +runs `else_branch`. -/ +public def ite_list_head {k : ℕ} {α : Type} [StrEnc α] (i : Fin k) + (v : α) (then_branch else_branch : MultiTapeTM k Char) : MultiTapeTM k Char := sorry + +@[simp] +public lemma ite_list_head_eval_struct {k : ℕ} {α : Type} [StrEnc α] {i : Fin k} + (v : α) + (then_branch else_branch : MultiTapeTM k Char) : + ∀ (ls : List Data) (views : Fin k → TapeView), + (views i = TapeView.ofList ls) → + (ite_list_head i v then_branch else_branch).eval_struct views = + if ls.head? = some (StrEnc.toData v) then + then_branch.eval_struct views + else + else_branch.eval_struct views := by sorry + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Copy.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Copy.lean new file mode 100644 index 0000000000..f4141bf96c --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Copy.lean @@ -0,0 +1,44 @@ +/- +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.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Untyped + +namespace Turing +namespace Routines + +/-- Copy a Data-encoded value from tape `i` to tape `j` + (prepending the encoding to tape `j`). -/ +public def copyEnc {k : ℕ} (i j : Fin k) : MultiTapeTM k Char := sorry + +/-- `copyEnc i j` copies the `Data` element at the current path position + of tape `i` and writes it to tape `j` (overwrites everything). + Tape `i` is not modified. -/ +@[simp] +public lemma copyEnc_eval_struct {k : ℕ} {i j : Fin k} + {views : Fin k → TapeView} + {h_ne : i ≠ j} : + (copyEnc i j).eval_struct views = some (Function.update views j + (.ofData (views i).current)) := by sorry + +@[simp, grind .] +public lemma copyEnc_computes_fun {k : ℕ} {α : Type} [StrEnc α] {i j : Fin k} (h_ne : i ≠ j) : + computes_function_read_replace (copyEnc i j) (id : α → α) i j := by + intro x y views h_read h_write + simp [copyEnc_eval_struct, h_ne] + grind + + +-- @[simp, grind .] +-- public def copyEnc_computes_fun {k : ℕ} {i j : Fin k} (h_ne : i ≠ j) : +-- ComputesFunctionReadPut (copyEnc i j) i j := by +-- sorry + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Eq.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Eq.lean new file mode 100644 index 0000000000..dbd7a965d6 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Eq.lean @@ -0,0 +1,51 @@ +/- +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.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed + +namespace Turing +namespace Routines + +/-- Compare Data-encoded values on tapes `i` and `j`. + Runs `tm_eq` if values are equal, `tm_neq` if not. + Tapes `i` and `j` are restored to their original positions. -/ +public def eqEnc {k : ℕ} (i j : Fin k) + (tm_eq tm_neq : MultiTapeTM k Char) : MultiTapeTM k Char := sorry + +/-- Compare values on tapes `i` and `j` and put the boolean result on tape `result`. -/ +public def isEq {k : ℕ} (i j : Fin k) (result : Fin k) : + MultiTapeTM k Char := + eqEnc i j (put (StrEnc.toData true) result) (put (StrEnc.toData false) result) + +-- TODo `DecidableEq` should be a consequence of `StrEnc`. +@[grind =>] +public lemma isEq.computes_fun {k : ℕ} (i j result : Fin k) + {α : Type} [StrEnc α] [BEq α] + (h_neq : [i, j, result].get.Injective) : + computes_function_read_read_push + (isEq i j result) + (fun (d₁ : α) (d₂ : α) => d₂ == d₁) i j result := by + sorry + +/-- `isEq i j result` compares the `Data` elements at the current positions + of tapes `i` and `j`, and writes the boolean result to tape `result` + (which must be empty). -/ +@[simp] +public lemma isEq_eval_struct {k : ℕ} {i j result : Fin k} + {views : Fin k → TapeView} + {d₁ d₂ : Data} + (h_current_i : (views i).current = some d₁) + (h_current_j : (views j).current = some d₂) + (h_empty_r : (views result).data = Data.list []) : + (isEq i j result).eval_struct views = some + (Function.update views result + (.ofEnc (decide ((views i).current = (views j).current)))) := by sorry + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/EvalFun.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/EvalFun.lean new file mode 100644 index 0000000000..d2d3618541 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/EvalFun.lean @@ -0,0 +1,79 @@ +/- +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.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed + +namespace Turing +namespace Routines + +/-- If a tape contains the encoding of a function, navigates to the value part belonging +to a certain input and executes `tm`. +TODO: Can probably be implemented using find_list. -/ +public def atFunctionValue {k : ℕ} (tm : MultiTapeTM k Char) (f input : Fin k) : + MultiTapeTM k Char := sorry + +/-- The index of the given value in the sorted list of all values of its type. -/ +public def indexInType {α : Type} [Fintype α] [LinearOrder α] (x : α) : ℕ := + (Finset.univ.sort (· ≤ ·)).idxOf x + +public lemma indexInTypeValid {α : Type} [Fintype α] [LinearOrder α] (x : α) : + indexInType x < Fintype.card α := by + simp [indexInType] + sorry + +@[simp] +public lemma atFunctionValue.eval_struct + {α β : Type} [StrEnc α] [Fintype α] [LinearOrder α] [StrEnc β] + {k : ℕ} (tm : MultiTapeTM k Char) {f input : Fin k} + (h_ne : f ≠ input) + {views : Fin k → TapeView} + {x : α} + {function : α → β} + (h_input : (views input).current = StrEnc.toData x) + (h_f : (views f).current = (StrEnc.ofFunction α β).toData function) : + (atFunctionValue tm f input).eval_struct views = (tm.eval_struct + (Function.update views f + ((views f).appendPath'' + [indexInType x, 1] (by simp [h_f, function_graph, Data.atPath, indexInTypeValid])))).map + fun views' => Function.update views' f ((views' f).parent.parent.setHeadPosOf (views f)) := by + sorry + +-- @[simp] +-- public lemma atPath_computes_function {k : ℕ} {path : List ℕ} {i j : Fin k} +-- {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] +-- {tm : MultiTapeTM k Char} +-- (h_ne : i ≠ j) +-- (fPath : α → β) +-- (h_path : ∀ x, ((StrEnc.toData x).atPath path) = some (StrEnc.toData (fPath x))) +-- (f : β → γ → γ) +-- (h_tm : computes_function_read_update' tm f i j) : +-- computes_function_read_update' (atPath path i tm) (fun a => f (fPath a)) i j := by +-- intro x y views h_views_i h_views_j +-- have h_d := h_path x +-- clear h_path +-- change (atPath path i tm).eval_struct views = +-- Part.some (Function.update views j (TapeView.ofEnc (f (fPath x) y))) +-- generalize StrEnc.toData x = d at h_d h_views_i +-- generalize fPath x = b at h_d ⊢ +-- induction path generalizing d views with +-- | nil => +-- simp only [Data.atPath_nil, Option.some.injEq] at h_d +-- exact h_tm b y views (by simp [h_views_i, h_d]) h_views_j +-- | cons n path' ih => +-- rw [show n :: path' = [n] ++ path' from rfl, Data.atPath_append] at h_d +-- obtain ⟨d₁, hd₁, h_tail⟩ := Option.bind_eq_some_iff.mp h_d +-- have h_valid : ((views i).current.atPath [n]).isSome := by simp [h_views_i, hd₁] +-- unfold atPath +-- rw [atElem_eval_struct h_valid] +-- rw [ih (Function.update views i ((views i).appendPath' n h_valid)) +-- (by simp [h_ne.symm, h_views_j]) d₁ (by simp; grind) h_tail] +-- simp [h_ne] + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Ite.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Ite.lean new file mode 100644 index 0000000000..4c273035e8 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Ite.lean @@ -0,0 +1,143 @@ +/- +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.MultiTapeTuring.StructuralMachines +public import Cslib.Computability.Machines.MultiTapeTuring.TapeView +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Iterate +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Navigation +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Skip + +namespace Turing +namespace Routines + +/-- Move left `n` times on tape `i`. -/ +public def left_n {k : ℕ} (n : ℕ) (i : Fin k) : MultiTapeTM k Char := + iterate_n (left i) n + +/-- Move right `n` times on tape `i`. -/ +public def right_n {k : ℕ} (n : ℕ) (i : Fin k) : MultiTapeTM k Char := + iterate_n (right i) n + +@[simp] +public lemma left_n.eval {k : ℕ} {n : ℕ} {i : Fin k} {tapes : Fin k → BiTape Char} : + (left_n n i).eval tapes = Part.some + (Function.update tapes i (BiTape.move_left^[n] (tapes i))) := by + simp [left_n, iterate_n_eval_of_total (fun t => left.eval)] + +@[simp] +public lemma right_n.eval {k : ℕ} {n : ℕ} {i : Fin k} {tapes : Fin k → BiTape Char} : + (right_n n i).eval tapes = Part.some + (Function.update tapes i (BiTape.move_right^[n] (tapes i))) := by + simp [right_n, iterate_n_eval_of_total (fun t => right.eval)] + +/-- Check characters left-to-right starting from the current (left-end) position. + After checking, returns the head to the original position before running + the then/else branch. -/ +public def ite_enc_from_left {k : ℕ} + (v : List Char) (i : Fin k) + (then_branch else_branch : MultiTapeTM k Char) : + MultiTapeTM k Char := match v with + | [] => then_branch + | c :: cs => if_eq c i + (right i;ₜ ite_enc_from_left cs i (left i;ₜ then_branch) (left i;ₜ else_branch)) + else_branch + +/-- Check a value by first moving left to the start, then comparing left-to-right, + then returning to the original (right-end) position. -/ +public def ite_enc_from_right {k : ℕ} + (v : List Char) (i : Fin k) + (then_branch else_branch : MultiTapeTM k Char) : + MultiTapeTM k Char := + left_n (v.length - 1) i;ₜ + ite_enc_from_left v i + (right_n (v.length - 1) i;ₜ then_branch) + (right_n (v.length - 1) i;ₜ else_branch) + +-- TODO simplify + +@[simp] +public lemma ite_enc_from_left.eval {k : ℕ} {v : List Char} {i : Fin k} + {then_branch else_branch : MultiTapeTM k Char} + {tapes : Fin k → BiTape Char} : + (ite_enc_from_left v i then_branch else_branch).eval tapes = + if ∀ n, (h : n < v.length) → + (BiTape.move_right^[n] (tapes i)).head = some v[n] + then + then_branch.eval tapes + else + else_branch.eval tapes := by + induction v generalizing tapes then_branch else_branch with + | nil => simp [ite_enc_from_left] + | cons c cs ih => + simp only [ite_enc_from_left, if_eq.eval] + by_cases h : (tapes i).head = some c + · simp only [h, ↓reduceIte, MultiTapeTM.seq_eval, right.eval, Part.bind_some, Part.bind_eq_bind] + rw [ih] + simp only [MultiTapeTM.seq_eval, left.eval, Part.bind_some, Part.bind_eq_bind, + Function.update_self, Function.update_idem, + BiTape.move_right_move_left, Function.update_eq_self] + congr 1 + ext + constructor <;> intro h' n hn + · match n with + | 0 => simpa using h + | n + 1 => simpa [Function.iterate_succ] using h' n (by simp_all) + · simpa [Function.iterate_succ] using h' (n + 1) (by simp_all) + · simp only [h, ↓reduceIte] + have : ¬∀ n, (hn : n < (c :: cs).length) → + (BiTape.move_right^[n] (tapes i)).head = some (c :: cs)[n] := by + intro h'; exact h (by simpa using h' 0 (by simp)) + exact (if_neg this).symm + +@[simp] +public lemma ite_enc_from_right.eval {k : ℕ} {v : List Char} {i : Fin k} + {then_branch else_branch : MultiTapeTM k Char} + {tapes : Fin k → BiTape Char} : + (ite_enc_from_right v i then_branch else_branch).eval tapes = + if ∀ n, (h : n < v.length) → + (BiTape.move_right^[n] (BiTape.move_left^[v.length - 1] (tapes i))).head = some v[n] + then + then_branch.eval tapes + else + else_branch.eval tapes := by + simp [ite_enc_from_right] + +/-- Runs `then_branch` if `(views i).current = v`, otherwise `else_branch`. + Works regardless of whether the head is at the left or right end. -/ +public def ite {k : ℕ} (v : Data) (i : Fin k) + (then_branch else_branch : MultiTapeTM k Char) : + MultiTapeTM k Char := + if_eq '(' i + (ite_enc_from_left v.enc i then_branch else_branch) + (ite_enc_from_right v.enc i then_branch else_branch) + +-- TODO simplify + +@[simp] +public lemma ite.eval_struct {k : ℕ} {v : Data} {i : Fin k} + {then_branch else_branch : MultiTapeTM k Char} + {views : Fin k → TapeView} : + (ite v i then_branch else_branch).eval_struct views = + if (views i).current = v then + then_branch.eval_struct views + else + else_branch.eval_struct views := by + simp only [ite, MultiTapeTM.eval_struct, if_eq.eval, Function.comp_apply] + rcases h_hp : (views i).headPos with _ | _ + case leftEnd => + simp only [TapeView.toBiTape_head_leftEnd _ h_hp, ↓reduceIte, ite_enc_from_left.eval] + have h_iff := TapeView.ite_enc_condition_iff (views i) h_hp v + split <;> simp_all + case rightEnd => + simp only [show ¬(views i).toBiTape.head = some '(' by + rw [TapeView.toBiTape_head_rightEnd _ h_hp]; decide, ↓reduceIte, ite_enc_from_right.eval] + have h_iff := TapeView.ite_enc_condition_right_iff (views i) h_hp v + split <;> simp_all + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Iterate.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Iterate.lean new file mode 100644 index 0000000000..22384ee059 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Iterate.lean @@ -0,0 +1,114 @@ +/- +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.MultiTapeTuring.StructuralMachines + +namespace Turing +namespace Routines + +/-- Iterating a pointwise update `fun t => Function.update t i (f (t i))` is the same as + iterating `f` on the `i`-th component. -/ +@[simp] +public lemma Function.iterate_update {α : Type*} {β : Type*} [DecidableEq α] + {i : α} {f : β → β} {g : α → β} {n : ℕ} : + (fun t => Function.update t i (f (t i)))^[n] g = Function.update g i (f^[n] (g i)) := by + induction n with + | zero => simp + | succ n ih => + simp only [Function.iterate_succ', Function.comp, ih, Function.update_self, + Function.update_idem] + +/-- Run a Turing machine `tm` sequentially `n` times. -/ +public def iterate_n {k : ℕ} (tm : MultiTapeTM k Char) : ℕ → MultiTapeTM k Char + | 0 => noop + | n + 1 => tm;ₜ iterate_n tm n + +@[simp] +public lemma iterate_n_zero {k : ℕ} {tm : MultiTapeTM k Char} : + iterate_n tm 0 = noop := by rfl + +public lemma iterate_n_succ {k : ℕ} {tm : MultiTapeTM k Char} {n : ℕ} : + iterate_n tm (n + 1) = tm;ₜ iterate_n tm n := by rfl + +public lemma iterate_n_succ' {k : ℕ} {tm : MultiTapeTM k Char} {n : ℕ} : + (iterate_n tm (n + 1)).eval = (iterate_n tm n;ₜ tm).eval := by + induction n with + | zero => + simp only [iterate_n_succ, iterate_n_zero] + funext tapes + rw [MultiTapeTM.seq_eval, MultiTapeTM.seq_eval] + simp [noop.eval] + | succ n ih => + funext tapes + simp only [iterate_n_succ] + simp only [MultiTapeTM.seq_eval] + change (tm.eval tapes).bind (fun t => (tm.eval t).bind fun s => (iterate_n tm n).eval s) = + ((tm.eval tapes).bind fun t => (iterate_n tm n).eval t).bind fun t => tm.eval t + rw [Part.bind_assoc] + congr 1 + funext tapes' + have := congr_fun ih tapes' + simp only [iterate_n_succ, MultiTapeTM.seq_eval] at this + exact this + +/-- Evaluating `iterate_n tm n` is the same as iterating the monadic bind `(· >>= tm.eval)`. -/ +@[simp] +public lemma iterate_n_eval_bind {k : ℕ} {tm : MultiTapeTM k Char} + {n : ℕ} {tapes : Fin k → BiTape Char} : + (iterate_n tm n).eval tapes = ((· >>= tm.eval)^[n]) (pure tapes) := by + have aux : ∀ (m : ℕ) (p : Part (Fin k → BiTape Char)), + p >>= (fun x => ((· >>= tm.eval)^[m]) (pure x)) = + ((· >>= tm.eval)^[m]) p := by + intro m + induction m with + | zero => simp + | succ m ihm => + intro p + simp only [Function.iterate_succ', Function.comp] + rw [← ihm, bind_assoc] + induction n generalizing tapes with + | zero => simp [iterate_n_zero, noop.eval] + | succ n ih => + rw [iterate_n_succ, MultiTapeTM.seq_eval] + change tm.eval tapes >>= (iterate_n tm n).eval = + ((· >>= tm.eval)^[n]) (pure tapes >>= tm.eval) + rw [pure_bind] + conv_lhs => arg 2; ext t; rw [ih] + exact aux n (tm.eval tapes) + +/-- If `tm` always produces `f tapes` on input `tapes`, then `iterate_n tm n` produces `f^[n]`. -/ +public lemma iterate_n_eval_of_total {k : ℕ} {tm : MultiTapeTM k Char} + {f : (Fin k → BiTape Char) → (Fin k → BiTape Char)} + (h : ∀ tapes, tm.eval tapes = Part.some (f tapes)) + {n : ℕ} {tapes : Fin k → BiTape Char} : + (iterate_n tm n).eval tapes = Part.some (f^[n] tapes) := by + rw [iterate_n_eval_bind] + induction n with + | zero => simp + | succ n ih => + simp only [Function.iterate_succ', Function.comp, ih] + change (Part.some (f^[n] tapes)).bind tm.eval = _ + rw [Part.bind_some, h] + +/-- Structural version: if `tm.eval_struct` always produces `f views`, + then `iterate_n tm n` produces `f^[n]`. -/ +@[simp] +public lemma iterate_n_eval_struct_of_total {k : ℕ} + {tm : MultiTapeTM k Char} + {f : (Fin k → TapeView) → (Fin k → TapeView)} + (h : ∀ views, tm.eval_struct views = Part.some (f views)) + {n : ℕ} {views : Fin k → TapeView} : + (iterate_n tm n).eval_struct views = Part.some (f^[n] views) := by + induction n generalizing views with + | zero => simp [iterate_n_zero, noop.eval_struct] + | succ n ih => + simp only [iterate_n_succ, seq_eval_struct, h, Part.bind_some] + exact ih + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/ListIteration.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/ListIteration.lean new file mode 100644 index 0000000000..c8862ae255 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/ListIteration.lean @@ -0,0 +1,250 @@ +/- +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.MultiTapeTuring.Routines.Boolean +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Skip +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Eq +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Navigation +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.CaseDispatch +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.While + +set_option autoImplicit false + +namespace Turing +namespace Routines + +-- ═══════════════════════════════════════════════════════════════════════════ +-- List iteration +-- ═══════════════════════════════════════════════════════════════════════════ + + +/-- Execute a Turing machine `tm` on every item in the Data.list on tape `i`, + assuming the state of tape `i` is reset by `tm`. -/ +public def run_list {k : ℕ} (i : Fin k) (tm : MultiTapeTM k Char) : + MultiTapeTM k Char := + right i;ₜ while_neq ')' i (tm;ₜ skipRight i);ₜ outOfList i + +-- TODO: clean up (ai) - we probably need lemmas about what skipRight on the last element means, +-- and that outOfList works when we are at the `)` of the list. + + +/-- If `tm` computes a function `f` that acts like a folding function, the result of using +`run_list` is a fold with accumulator on tape `j`. -/ +@[simp, grind =>] +public lemma run_list_fold {k : ℕ} {i j : Fin k} (h_neq : i ≠ j) + {α β : Type} [StrEnc α] [StrEnc β] + {tm : MultiTapeTM k Char} + (f : α → β → β) + (h_comp : computes_function_read_update' tm f i j) : + computes_function_read_update' (α := List α) (run_list i tm) + (fun ls => ls.foldl (fun acc d => f d acc)) i j := by + sorry + +/-- TODO document -/ +public def any_list {k : ℕ} + (tm : MultiTapeTM k Char) (i j : Fin k) : MultiTapeTM k Char := + pushList (StrEnc.toData false) j;ₜ run_list i (tm;ₜ combineOrUpdate j) + +@[simp, grind =>] +public theorem any_list.computes_fun {k : ℕ} {i j : Fin k} + (h_neq : i ≠ j) + {α : Type} [StrEnc α] + {tm : MultiTapeTM k Char} + {f : α → Bool} + (h_comp : computes_function_read_push tm f i j) : + computes_function_read_push (α := List α) + (any_list tm i j) + (fun ls => ls.any f) + i j := by + -- intro ls views h_ls + -- have h_inner : computes_function_read_update (tm;ₜ combineOrUpdate j) (fun d tv => + -- let b := f d + -- let acc := (tv.current.at? 0).map (fun d => d = StrEnc.toData true) = some true + -- if b then tv.pushList (StrEnc.toData true) + -- else if acc then tv + -- else tv.pushList (StrEnc.toData false)) i j h_neq := by + -- grind [combineOrUpdate] + sorry + +@[grind =>] +public theorem any_list.computes_fun_twoary {k : ℕ} {i j r : Fin k} + {α β : Type} [StrEnc α] [StrEnc β] + (h_neq : [i, j, r].get.Injective) + {tm : MultiTapeTM k Char} + {f : α → β → Bool} + (h_comp : computes_function_read_read_push tm f i j r) : + computes_function_read_read_push (α := List α) + (any_list tm i r) + (fun ls y => ls.any (fun d => f d y)) + i j r := by + sorry + +@[simp, grind =>] +public theorem any_list.computes_fun' {k : ℕ} {i j : Fin k} + (h_neq : i ≠ j) + {α : Type} [StrEnc α] + {tm : MultiTapeTM k Char} + {f : α → Bool} + (h_comp : computes_function_read_push' tm f i j) : + computes_function_read_push' + (any_list tm i j) + (fun ls : List α => ls.any f) + i j := by + intro ls out_ls views h_ls h_out_ls + have h_inner : computes_function_read_update' (tm;ₜ combineOrUpdate j) + (fun x out_ls => (f x || out_ls.head? == some true) :: out_ls.tail) i j := by + intro x out_ls views h_acc h_out_ls + simp [h_comp x out_ls views h_acc h_out_ls, + combineOrUpdate.computes_fun ((f x) :: out_ls), List.head?_eq_getElem?] + simp only [any_list, Bool.toData, seq_eval_struct, pushList_eval_struct, Part.coe_some, + Part.bind_some] + rw [(run_list_fold h_neq _ h_inner ls (false :: out_ls) _ (by simp [h_neq, h_ls]) + (by simp [StrEnc.toData, h_out_ls, TapeView.pushList]))] + have h_any_fold : ∀ ls : List α, ∀ first, + ls.foldl (fun acc d => ((f d) || acc.head? == some true) :: acc.tail) (first :: out_ls) = + (first || ls.any f) :: out_ls := by + intro ls + induction ls with + | nil => simp + | cons d rest ih => + unfold List.foldl + intro first + simp [ih (f d || first)] + grind + simp [h_any_fold] + + +/-- Run `tm` on every item of the list on tape `i`, assuming `tm` outputs a boolean + value to tape `tmp`, and compute the logical AND of the results across the list. -/ +public def all_list {k : ℕ} (tm : MultiTapeTM k Char) (i j : Fin k) : MultiTapeTM k Char := + any_list (tm;ₜ negateBool j) i j;ₜ negateBool j + +@[simp, grind =>] +public theorem all_list.computes_fun {k : ℕ} (i j : Fin k) + (h_neq : i ≠ j) + {α : Type} [StrEnc α] + {tm : MultiTapeTM k Char} + {f : α → Bool} + (h_comp : computes_function_read_push tm f i j) : + computes_function_read_push + (all_list tm i j) + (List.all · f) + i j := by + simp only [all_list, List.all_eq_not_any_not] + grind + +-- TODO why does the simp linter complain here? +@[grind =>] +public theorem all_list.computes_fun_twoary {k : ℕ} {i j r : Fin k} + {α β : Type} [StrEnc α] [StrEnc β] + (h_neq : [i, j, r].get.Injective) + {tm : MultiTapeTM k Char} + {f : α → β → Bool} + (h_comp : computes_function_read_read_push tm f i j r) : + computes_function_read_read_push (α := List α) + (all_list tm i r) + (fun ls y => ls.all (fun d => f d y)) + i j r := by + simp only [all_list, List.all_eq_not_any_not] + grind + +/-- Check if the value on tape `j` is contained in the list on tape `i` + and store the boolean result on tape `result`. -/ +public def contains {k : ℕ} (i j result : Fin k) : MultiTapeTM k Char := + any_list (isEq i j result) i result + +-- TODO why does the simp linter complain here? +@[grind =>] +public lemma contains.computes_fun {k : ℕ} + {α : Type} [BEq α] [StrEnc α] + {i j result : Fin k} + (h_inj : [i, j, result].get.Injective) : + computes_function_read_read_push + (contains i j result) + (fun (ls : List α) x => ls.contains x) + i j result := by + simp only [List.contains_eq_any_beq] + have := isEq.computes_fun (α := α) i j result h_inj + grind [contains] + + +-- @[simp] +-- public lemma contains_eval_struct {k : ℕ} {i j result : Fin k} +-- (h_inj : [i, j, result].get.Injective) +-- {views : Fin k → TapeView} : +-- (contains i j result h_inj).eval_struct views = some (Function.update views result ((do +-- let ls <- (views i).currentList +-- let item <- (views j).current +-- return (views result).pushList (StrEnc.toData (ls.contains item)) +-- ).getD (views result))) := by +-- have x := contains.computes_fun h_inj views +-- simp at x +-- sorry + +inductive FindMapState where + | searching + | found + | notFound + +instance : StrEnc FindMapState where + toData + | FindMapState.searching => StrEnc.toData 0 + | FindMapState.found => StrEnc.toData 1 + | FindMapState.notFound => StrEnc.toData 2 + +/-- Execute `tm₁` on every item in the list on tape `i`. For the first item where it +writes `true` to tape `j`, execute `tm₂`. If it never writes `true`, execute `tm₃` after +returning to the list start. -/ +public def find_list {k : ℕ} (i j : Fin k) (tm₁ tm₂ tm₃ : MultiTapeTM k Char) : + MultiTapeTM k Char := + replace (StrEnc.toData FindMapState.searching) j;ₜ + right i;ₜ + doWhileEq (StrEnc.toData FindMapState.searching) j ( + if_eq ')' i + (replace (StrEnc.toData FindMapState.notFound) j;ₜ outOfList i) + (tm₁;ₜ Routines.ite (StrEnc.toData true) j + (replace (StrEnc.toData FindMapState.found) j) + (replace (StrEnc.toData FindMapState.searching) j;ₜ skipRight i)));ₜ + Routines.ite (StrEnc.toData FindMapState.found) j + (clear j;ₜ tm₂) + (clear j;ₜ tm₃) + +public theorem find_list.computes_fun {k : ℕ} {i j : Fin k} + (h_neq : i ≠ j) + {α : Type} [StrEnc α] + {tm₁ tm₂ tm₃ : MultiTapeTM k Char} + {f : α → Bool} + (h_comp₁ : computes_function_read_replace tm₁ f i j) + (views : Fin k → TapeView) : + ∀ ls : List α, (views i).current = StrEnc.toData ls → + views j = TapeView.empty → + (find_list i j tm₁ tm₂ tm₃).eval_struct views = match ls.findIdx? f with + | some idx => tm₂.eval_struct (Function.update views i ((views i).appendPath' idx (by sorry))) + | none => tm₃.eval_struct views := by + sorry + +-- public theorem find_list.eval_struct {k : ℕ} {i j : Fin k} +-- (h_neq : i ≠ j) +-- {tm₁ tm₂ tm₃ : MultiTapeTM k Char} +-- (halts₁ : AlwaysHaltsOnStruct tm₁) +-- -- {f : α → Bool} +-- -- TODO maybe instead of this, we need that tm₁ does not modify tape i. +-- -- (h_comp₁ : computes_function_read_replace tm₁ f i j) +-- (views : Fin k → TapeView) : +-- (find_list i j tm₁ tm₂ tm₃).eval_struct views = +-- let length := (views i).current.toList.length +-- let condition := fun (⟨idx, h⟩ : Fin length) => (tm₁.eval_struct_tot halts₁ +-- (Function.update views i ((views i).appendPath' idx (by sorry))) +-- j).current = StrEnc.toData true +-- match Fin.find? condition with +-- | some idx => tm₂.eval_struct (Function.update views i ((views i).appendPath' idx (by sorry))) +-- | none => tm₃.eval_struct views := by +-- sorry + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/ListOps.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/ListOps.lean new file mode 100644 index 0000000000..7ac8547a6d --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/ListOps.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.Computability.Machines.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed + +namespace Turing +namespace Routines + +-- ═══════════════════════════════════════════════════════════════════════════ +-- List operations +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- Prepend a Data element to a list encoding on tape `i`. -/ +public def pushList {k : ℕ} (d : Data) (i : Fin k) : MultiTapeTM k Char := + write none i;ₜ right i;ₜ put d i;ₜ left i;ₜ write '(' i + +@[simp] +public lemma pushList.computes_fun {k : ℕ} {d : Data} {i : Fin k} : + computes_function_update (pushList d i) (fun (ls : List Data) => d :: ls) i := by + sorry + +/-- Prepend the Data element from tape `i` to the list at tape `j` (prepends it). -/ +public def copy_to_list {k : ℕ} (i j : Fin k) : MultiTapeTM k Char := sorry + +@[simp] +public lemma copy_to_list.eval_struct {k : ℕ} {i j : Fin k} (h_ne : i ≠ j) + {views : Fin k → TapeView} : + (copy_to_list i j).eval_struct views = some + (Function.update views j ((views j).pushList (views i).current)) := by + sorry + +@[simp] +public lemma copy_to_list.computes_fun {α : Type} [StrEnc α] {k : ℕ} {i j : Fin k} (h_ne : i ≠ j) : + computes_function_read_push (α := α) (copy_to_list i j) id i j := by + sorry + +@[simp] +public lemma copy_to_list.computes_fun' {α : Type} [StrEnc α] {k : ℕ} {i j : Fin k} (h_ne : i ≠ j) : + computes_function_read_push' (α := α) (copy_to_list i j) id i j := by + sorry + +/-- Remove the first element from a list encoding on tape `i`. + Running `popEnc` on an empty list does not modify the tape. -/ +public def popList {k : ℕ} (i : Fin k) : MultiTapeTM k Char := sorry + +/-- `pushList d i` prepends a Data element to the topmost `Data.list` on tape `i`. -/ +@[simp] +public lemma pushList_eval_struct {k : ℕ} {d : Data} {i : Fin k} + {views : Fin k → TapeView} : + (pushList d i).eval_struct views = some + (Function.update views i ((views i).pushList d)) := by + simp only [MultiTapeTM.eval_struct, pushList, MultiTapeTM.seq_eval] + sorry + -- match h_vi : views i with + -- | ⟨Data.list ds, [], _⟩ => + -- -- Step 1: compute toBiTape for this view + -- have h_bi : (views i).toBiTape = + -- BiTape.mk₁ ('(' :: (ds.map Data.enc).flatten ++ [')']) := by + -- simp [h_vi, TapeView.toBiTape, TapeView.encodedPos, Data.enc_list] + -- -- Step 2: write none + right produces mk₁ (flat ++ [')']) + -- have h_wr : ((BiTape.mk₁ + -- ('(' :: (ds.map Data.enc).flatten ++ [')'])).write none).move_right = + -- BiTape.mk₁ ((ds.map Data.enc).flatten ++ [')']) := by + -- simp [BiTape.mk₁, BiTape.write, BiTape.move_right, + -- StackTape.cons_none_nil, StackTape.nil_head, StackTape.nil_tail, + -- StackTape.map_some_head, StackTape.map_some_tail] + -- -- Now chain: unfold eval_struct, use eval simp lemmas, put_eval, and connect back + -- simp [TapeView.pushList, h_vi, Data.enc_list, + -- TapeView.toBiTape, TapeView.encodedPos, + -- write.eval, right.eval, left.eval, put_eval, + -- Function.update_idem, Function.update_self, + -- Function.iterate_zero, h_bi, h_wr, + -- Part.bind_some, BiTape.mk₁, BiTape.move_left, BiTape.write, + -- StackTape.cons_none_nil, StackTape.nil_head, StackTape.nil_tail, + -- StackTape.map_some_head, StackTape.map_some_tail, + -- ← TapeView.toBiTape_comp_update, TapeView.ofBiTapes?_toBiTape] + -- | ⟨Data.list _, _ :: _, _⟩ => + -- simp only [TapeView.pushList, h_vi] + -- sorry + -- | ⟨Data.num _, [], _⟩ => + -- simp only [TapeView.pushList, h_vi] + -- sorry + -- | ⟨Data.num _, _ :: _, _⟩ => + -- simp only [TapeView.pushList, h_vi] + -- sorry + +@[simp] +public lemma popList_eval_struct {k : ℕ} {i : Fin k} + {views : Fin k → TapeView} : + (popList i).eval_struct views = some + (Function.update views i (views i).popList) := by sorry + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Navigation.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Navigation.lean new file mode 100644 index 0000000000..494edd5159 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Navigation.lean @@ -0,0 +1,251 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.MultiTapeTuring.StructuralMachines +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Iterate +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Skip +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed + + +namespace Turing +namespace Routines + + + +/-- Run `tm` at the left end of the current item, restoring to the original position afterwards. -/ +public def atLeft {k : ℕ} (i : Fin k) (tm : MultiTapeTM k Char) : MultiTapeTM k Char := + if_eq '(' i tm (toLeftEnd i;ₜ tm;ₜ toRightEnd i) + +@[simp] +public lemma atLeft_eval_struct {k : ℕ} {i : Fin k} (tm : MultiTapeTM k Char) + {views : Fin k → TapeView} : + (atLeft i tm).eval_struct views = + (tm.eval_struct (Function.update views i ((views i).toLeftEnd))).map + (fun views' => Function.update views' i ((views' i).setHeadPosOf (views i))) := by + simp [atLeft] + sorry -- TOOD prove by AI + + +def skipRight_n {k : ℕ} (n : ℕ) (i : Fin k) : MultiTapeTM k Char := + iterate_n (skipRight i) n + +-- TODO maybe we can change this to +-- lemma skipRight_n.eval_struct {j n : ℕ} {k : ℕ} {i : Fin k} +-- {views : Fin k → TapeView} +-- (h_valid : ((views i).parent.current.atPath [j + n]).isSome) +-- (h_parent : (views i) = (views i).parent.appendPath j +-- (Data.atPath_isSome_of_le_isSome (by simp) h_valid)) +-- (h_left : (views i).headPos = .leftEnd) : + + +lemma skipRight_n.eval_struct {j n : ℕ} {k : ℕ} {i : Fin k} + {views : Fin k → TapeView} + {parent : TapeView} + (h_valid : (parent.current.atPath [j + n]).isSome) + (h_left : parent.headPos = .leftEnd) + (h_parent : (views i) = parent.appendPath j + (Data.atPath_isSome_of_le_isSome (by simp) h_valid)) : + (skipRight_n n i).eval_struct views = .some (Function.update views i + ((views i).parent.appendPath (j + n) + (by simpa [h_parent] using h_valid))) := by + induction n generalizing j views with + | zero => simp [skipRight_n, iterate_n_zero, h_parent] + | succ n ih => + have h_j1 : (parent.current.atPath [j + 1]).isSome := + Data.atPath_isSome_of_le_isSome (by omega) h_valid + simp only [skipRight_n, iterate_n_succ, seq_eval_struct] + rw [skipRight_eval_struct + (by simp [h_parent]) (by simp [h_parent, h_left])] + simp only [Part.bind_some, h_parent, + TapeView.appendPath, TapeView.parent, List.dropLast_concat, + List.getLast?_concat, Option.get_some, Nat.succ_eq_add_one] + rw [dif_pos h_j1, + show iterate_n (skipRight i) n = skipRight_n n i from rfl, + ih (by rwa [show j + 1 + n = j + (n + 1) from by omega]) + (by simp)] + simp only [Function.update_idem, Function.update_self, + TapeView.appendPath, TapeView.parent, List.dropLast_concat, + show j + 1 + n = j + (n + 1) from by omega] + + +/-- If positioned on the element of a list, navigates to the list containing it. -/ +public def outOfList {k : ℕ} (i : Fin k) : MultiTapeTM k Char := + left i;ₜ while_eq ')' i (right i;ₜ skipLeft i;ₜ left i) + +-- ((1)(2)(3)) + +lemma outOfList_inner {k : ℕ} {i : Fin k} + (views : Fin k → TapeView) + {tv : TapeView} + (idx : ℕ) + (path : List ℕ) + (h_path : tv.path = path ++ [idx.succ]) + (h_left : tv.headPos = .leftEnd) : + (right i;ₜ skipLeft i;ₜ left i).eval_tot (by grind) + (Function.update (TapeView.toBiTape ∘ views) i tv.toBiTape.move_left) = + Function.update (TapeView.toBiTape ∘ views) i + (tv.parent.appendPath idx (by + apply Data.atPath_isSome_of_succ_isSome + sorry + )).toBiTape.move_left := by + sorry + +/-- `outOfArg i` ascends back from within a list to the list itself. -/ +@[simp] +public lemma outOfList_eval_struct {k : ℕ} {i : Fin k} {views : Fin k → TapeView} : + (outOfList i).eval_struct views = some (Function.update views i (views i).parent) := by sorry + +public lemma outOfList_eval_struct' {k : ℕ} {i : Fin k} : + (outOfList i).eval_struct = fun views => .some (Function.update views i (views i).parent) := by sorry + + +/-- Navigate to the `idx`-th element of a `Data.list` encoding on tape `i`. +Moves past `(` and then skips `idx` Data elements. +If `i` is larger than the length of the list, does nothing. -/ +public def toElem {k : ℕ} (idx : ℕ) (i : Fin k) : MultiTapeTM k Char := + toLeftEnd i;ₜ right i;ₜ skipRight_n idx i + +/-- `toElem idx i` moves to the `idx`th element of the `Data.list` currently pointed to +on tape `i`. -/ +@[simp] +public lemma toElem_eval_struct {k : ℕ} {idx : ℕ} {i : Fin k} {views : Fin k → TapeView} + (h_valid : ((views i).current.atPath [idx]).isSome) : + (toElem idx i).eval_struct views = .some + (Function.update views i ((views i).appendPath' idx h_valid)) := by + have h_ne : (views i).current ≠ Data.list [] := + Data.atPath_zero_isSome_of_nonempty.mp + (Data.atPath_isSome_of_le_isSome (by omega) h_valid) + simp only [toElem, seq_eval_struct, toLeftEnd_eval_struct, Part.bind_some, right_eval_struct, + Part.bind_some, Function.update_idem, Function.update_self, + show ¬(views i).toLeftEnd.current = Data.list [] from h_ne, ↓reduceDIte] + rw [skipRight_n.eval_struct (j := 0) (parent := (views i).toLeftEnd) + (by simpa using h_valid) (by simp) (by simp)] + simp + +-- TODO this has a double toLeftEnd which is not needed. + +/-- Execute `tm` at a certain element of the list. -/ +public def atElem {k : ℕ} (idx : ℕ) (i : Fin k) (tm : MultiTapeTM k Char) : MultiTapeTM k Char := + atLeft i (toElem idx i;ₜ tm;ₜ outOfList i) + +@[simp] +public lemma atElem_eval_struct {k : ℕ} {idx : ℕ} {i : Fin k} {tm : MultiTapeTM k Char} + {views : Fin k → TapeView} + (h_valid : ((views i).current.atPath [idx]).isSome) : + (atElem idx i tm).eval_struct views = (tm.eval_struct + (Function.update views i ((views i).appendPath' idx h_valid))).map + fun views' => Function.update views' i ((views' i).parent.setHeadPosOf (views i)) := by + simp [atElem, h_valid, Part.bind_some_eq_map] + +/-- The semantics of `atElem` when applied to a static index. This is not really useful +when applied to a `List` because `fElem` needs to compute the elem for any valid `x` of the type. -/ +@[simp] +public lemma atElem_computes_function {k : ℕ} {idx : ℕ} {i j : Fin k} + {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] + {tm : MultiTapeTM k Char} + (h_ne : i ≠ j) + (fElem : α → β) + (h_elem : ∀ x, ((StrEnc.toData x).atPath [idx]) = some (StrEnc.toData (fElem x))) + (f : β → γ → γ) + (h_tm : computes_function_read_update' tm f i j) : + computes_function_read_update' (atElem idx i tm) (fun a => f (fElem a)) i j := by + intro x y views h_views_i h_views_j + rw [atElem_eval_struct (by simp [h_views_i, h_elem])] + rw [h_tm (fElem x) y _ (by simp; grind) (by grind)] + simp [h_ne] + +/-- Like atElem, but execute tm₁ if the element exists and tm₂ otherwise. -/ +public def atElem? {k : ℕ} (idx : ℕ) (i : Fin k) (tm₁ tm₂ : MultiTapeTM k Char) : + MultiTapeTM k Char := sorry + +@[simp] +public lemma atElem?_eval_struct {k : ℕ} {idx : ℕ} {i : Fin k} {tm₁ tm₂ : MultiTapeTM k Char} + {views : Fin k → TapeView} : + (atElem? idx i tm₁ tm₂).eval_struct views = + if h : ((views i).current.atPath [idx]).isSome then + (tm₁.eval_struct + (Function.update views i ((views i).appendPath' idx h))).map + fun views' => Function.update views' i ((views' i).parent.setHeadPosOf (views i)) + else + (tm₂.eval_struct views) := by + sorry + +-- TODO this has a double toLeftEnd which is not needed. + +/-- Move into the given path, then execute `tm` and then move out again. -/ +public def atPath {k : ℕ} (path : List ℕ) (i : Fin k) (tm : MultiTapeTM k Char) : + MultiTapeTM k Char := + match path with + | [] => tm + | n :: path' => atElem n i (atPath path' i tm) + +@[simp] +public lemma atPath_computes_function {k : ℕ} {path : List ℕ} {i j : Fin k} + {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] + {tm : MultiTapeTM k Char} + (h_ne : i ≠ j) + (fPath : α → β) + (h_path : ∀ x, ((StrEnc.toData x).atPath path) = some (StrEnc.toData (fPath x))) + (f : β → γ → γ) + (h_tm : computes_function_read_update' tm f i j) : + computes_function_read_update' (atPath path i tm) (fun a => f (fPath a)) i j := by + intro x y views h_views_i h_views_j + have h_d := h_path x + clear h_path + change (atPath path i tm).eval_struct views = + Part.some (Function.update views j (TapeView.ofEnc (f (fPath x) y))) + generalize StrEnc.toData x = d at h_d h_views_i + generalize fPath x = b at h_d ⊢ + induction path generalizing d views with + | nil => + simp only [Data.atPath_nil, Option.some.injEq] at h_d + exact h_tm b y views (by simp [h_views_i, h_d]) h_views_j + | cons n path' ih => + rw [show n :: path' = [n] ++ path' from rfl, Data.atPath_append] at h_d + obtain ⟨d₁, hd₁, h_tail⟩ := Option.bind_eq_some_iff.mp h_d + have h_valid : ((views i).current.atPath [n]).isSome := by simp [h_views_i, hd₁] + unfold atPath + rw [atElem_eval_struct h_valid] + rw [ih (Function.update views i ((views i).appendPath' n h_valid)) + (by simp [h_ne.symm, h_views_j]) d₁ (by simp; grind) h_tail] + simp [h_ne] + + +/-- Move into the given path, if it exists, then execute `tm₁` and then move out again, +if it does not exist, execute `tm₂` at the initial position. -/ +public def atPath? {k : ℕ} (path : List ℕ) (i : Fin k) (tm₁ tm₂ : MultiTapeTM k Char) : + MultiTapeTM k Char := + match path with + | [] => atLeft i tm₁ + | n :: path' => atElem? n i (atPath? path' i tm₁ (outOfList i ;ₜ tm₂)) tm₂ + + +@[simp] +public lemma atPath?_eval_struct {k : ℕ} {path : List ℕ} {i : Fin k} {tm₁ tm₂ : MultiTapeTM k Char} + {views : Fin k → TapeView} : + (atPath? path i tm₁ tm₂).eval_struct views = + if h : ((views i).current.atPath path).isSome then + (tm₁.eval_struct (Function.update views i ((views i).appendPath'' path h))).map + fun views' => Function.update views' i + (((views' i).parent_n path.length).setHeadPosOf (views i)) + else + (tm₂.eval_struct views) := by + induction path generalizing views tm₁ tm₂ with + | nil => simp [atPath?] + | cons n path' ih => + unfold atPath? + by_cases h : ((views i).current.atPath [n]).isSome + · simp [h, -TapeView.parent, -TapeView.appendPath', -TapeView.appendPath''] + rw [ih] + simp + sorry + · simp [h] + sorry -- TODO what is left is the first case which is a contradiction + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Put.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Put.lean new file mode 100644 index 0000000000..ae7d79adb4 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Put.lean @@ -0,0 +1,103 @@ +/- +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.MultiTapeTuring.StructuralMachines + +namespace Turing +namespace Routines + +-- ═══════════════════════════════════════════════════════════════════════════ +-- Put characters and Data values +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- Write a list of characters to tape `i` by repeatedly moving left and writing, + effectively prepending the characters to the tape content. -/ +public def putChars : List Char → Fin k → MultiTapeTM k Char + | [], _ => noop + | c :: rest, i => putChars rest i;ₜ left i;ₜ write c i + +/-- Prepend the encoding of a `Data` value to tape `i`. -/ +public def put {k : ℕ} (d : Data) (i : Fin k) : MultiTapeTM k Char := + putChars (Data.enc d) i + +public lemma put_eval {k : ℕ} {d : Data} {i : Fin k} + {tapes : Fin k → BiTape Char} + {old : List Char} + (h_tape : (tapes i) = BiTape.mk₁ old) : + (put d i).eval tapes = some + (Function.update tapes i (BiTape.mk₁ (d.enc ++ old))) := by + unfold put + induction d.enc with + | nil => simp [putChars, h_tape] + | cons c rest ih => + simp [putChars, ih, BiTape.mk₁, BiTape.move_left, BiTape.write] + cases rest <;> cases old <;> simp [StackTape.map_some, StackTape.cons, StackTape.nil] + +/-- TODO document -/ +public def clear (i : Fin k) : MultiTapeTM k Char := while_neq none i (write none i;ₜ right i) + +@[simp] +theorem clear.eval_inner {i : Fin k} {tapes : Fin k → BiTape Char} {ls : List Char} : + Function.update tapes i ((Turing.BiTape.mk₁ ls).write none).move_right = + Function.update tapes i (BiTape.mk₁ ls.tail) := by + ext1 j + by_cases h_ij : i = j + · subst h_ij + simp only [Function.update_self] + cases ls with | nil | cons _ _ <;> + simp [BiTape.mk₁, BiTape.write, BiTape.move_right] + · have h : i ≠ j := by omega + grind + +lemma clear.eval_inner_iter {i : Fin k} {tapes : Fin k → BiTape Char} (ls : List Char) + (h_tape_i : tapes i = BiTape.mk₁ ls) + (n : ℕ) + (h_n : n ≤ ls.length) : + ((write none i;ₜ right i).eval_tot (by simp))^[n] tapes = + Function.update tapes i (BiTape.mk₁ (ls.drop n)) := by + induction n with + | zero => simp [h_tape_i] + | succ n ih => + rw [Function.iterate_succ_apply', ih (by omega)] + simp + +-- TODO change this so that it does not need `ls` but works with a tape and a condition that +-- the left side is empty +public theorem clear.eval {i : Fin k} {tapes : Fin k → BiTape Char} {ls : List Char} + (h_tape_i : tapes i = BiTape.mk₁ ls) : + (clear i).eval tapes = .some (Function.update tapes i (BiTape.mk₁ [])) := by + have h_min : ∀ n' < ls.length, + (((write none i;ₜ right i).eval_tot (by simp))^[n'] tapes i).head ≠ none := by + intro n' h_n' + rw [clear.eval_inner_iter ls h_tape_i n' (by omega)] + simp [Function.update_self, BiTape.mk₁, h_n'] + unfold clear + rw [while_neq.eval' ls.length + (by rw [clear.eval_inner_iter ls h_tape_i ls.length (by omega)]; simp [BiTape.mk₁]) + h_min] + rw [clear.eval_inner_iter ls h_tape_i ls.length (by omega)] + simp + + +/-- Replace the contents of tape `i` by the encoding of `d`. -/ +public def replace {k : ℕ} (d : Data) (i : Fin k) : MultiTapeTM k Char := + sorry + -- TODO move to the left and then + -- clear i;ₜ put d i + +@[simp] +public lemma replace.eval_struct {k : ℕ} {d : Data} {i : Fin k} {views : Fin k → TapeView} : + (replace d i).eval_struct views = some (Function.update views i (.ofData d)) := by + sorry + -- simp only [MultiTapeTM.eval_struct, replace, MultiTapeTM.seq_eval] + -- rw [clear.eval (ls := (views i).data.enc) (by simp [TapeView.toBiTape, h_data, h_left])] + -- simp [put_eval (old := []), ← TapeView.toBiTape_ofData] + + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Skip.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Skip.lean new file mode 100644 index 0000000000..bb26f0d095 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Skip.lean @@ -0,0 +1,107 @@ +/- +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.MultiTapeTuring.StructuralMachines + +namespace Turing +namespace Routines + +-- ═══════════════════════════════════════════════════════════════════════════ +-- Skip right / left across a Data-encoded value +-- ═══════════════════════════════════════════════════════════════════════════ + +-- TODO If we do not specify a max nesting depth when constructing the skip +-- machine, it requires an additional tape to count the nesting depth. +-- if the nesting depth is bounded by a constant, this is still fine, +-- but we need to account for it - so maybe it's better to just do it +-- when constructing it? + +/-- Skip to the right across a Data-encoded value. -/ +public def skipRight {k : ℕ} (i : Fin k) : MultiTapeTM k Char := sorry + +/-- Skip to the left across a Data-encoded value (inverse of `skipRight`). -/ +public def skipLeft {k : ℕ} (i : Fin k) : MultiTapeTM k Char := sorry + +/-- Move to the left end of the current item. -/ +public def toLeftEnd {k : ℕ} (i : Fin k) : MultiTapeTM k Char := sorry + +/-- Move to the right end of the current item. -/ +public def toRightEnd {k : ℕ} (i : Fin k) : MultiTapeTM k Char := sorry + +/-- Run `tm` at the left end of the current item, and return to the original +position afterwards. -/ +public def atLeftEnd {k : ℕ} (i : Fin k) (tm : MultiTapeTM k Char) : MultiTapeTM k Char := sorry + +@[simp, grind =>] +public lemma skipLeft_haltsOn {k : ℕ} (i : Fin k) : ∀ t, (skipLeft i).HaltsOn t := by + sorry + +@[simp, grind =>] +public lemma skipRight_haltsOn {k : ℕ} (i : Fin k) : ∀ t, (skipRight i).HaltsOn t := by + sorry + +-- TODO move the two conditions into the body + +/-- `skipRight i` moves to the next sibling element within a list, + incrementing the last path index, or to the end of the list. -/ +@[simp] +public lemma skipRight_eval_struct {k : ℕ} {i : Fin k} + {views : Fin k → TapeView} + (h_nonempty : (views i).path.getLast?.isSome) + (h_left : (views i).headPos = .leftEnd) : + (skipRight i).eval_struct views = .some (Function.update views i ( + let idx : ℕ := (views i).path.getLast?.get h_nonempty + if h_next : ((views i).parent.current.atPath [idx.succ]).isSome then + (views i).parent.appendPath idx.succ h_next + else + (views i).parent.toRightEnd)) := by sorry + +/-- `skipLeft i` is the inverse of `skipRight i`. + When positioned at the right end of a non-empty list, it moves to the + left end of the last entry in the list. + When positioned at the left end of a non-first item in a list, it moves + to the left end of the previous item. -/ +@[simp] +public lemma skipLeft_eval_struct {k : ℕ} {i : Fin k} {views : Fin k → TapeView} : + (skipLeft i).eval_struct views = .some (Function.update views i ( + if h_right : (views i).headPos = .rightEnd then + if h_empty : (views i).current = .list [] then + views i + else + ((views i).appendPath ((views i).current.toList.length - 1) (by simp [h_empty])).toLeftEnd + else + if h_path : (views i).path.getLast?.isSome then + let idx := (views i).path.getLast?.get h_path + if h_prev : 0 < idx then + (views i).parent.appendPath (idx - 1) (by + unfold TapeView.current; + apply Data.atPath_isSome_of_le_isSome (show idx - 1 ≤ idx from by omega) + simp [idx]) + else + views i + else + views i)) := by sorry + +@[simp] +public lemma toLeftEnd_eval_struct {k : ℕ} {i : Fin k} {views : Fin k → TapeView} : + (toLeftEnd i).eval_struct views = .some (Function.update views i (views i).toLeftEnd) := by + sorry + +@[simp] +public lemma toRightEnd_eval_struct {k : ℕ} {i : Fin k} {views : Fin k → TapeView} : + (toRightEnd i).eval_struct views = .some (Function.update views i (views i).toRightEnd) := by + sorry + +@[simp] +public lemma atLeftEnd_eval_struct {k : ℕ} {i : Fin k} {tm : MultiTapeTM k Char} + {views : Fin k → TapeView} : + (atLeftEnd i tm).eval_struct views = .some (Function.update views i (views i).toLeftEnd) := by + sorry + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/Typed.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Typed.lean new file mode 100644 index 0000000000..c2a6193233 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/Typed.lean @@ -0,0 +1,169 @@ +/- +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.MultiTapeTuring.TapeView +public import Cslib.Computability.Machines.MultiTapeTuring.StructuralMachines + +namespace Turing +namespace Routines + +/-- Turing machine `tm` computes a function on data from tape `i` and updates tape `j`. -/ +-- TODO move this somewhere else +@[expose] +public def computes_function_update {k : ℕ} + {α : Type} [StrEnc α] + (tm : MultiTapeTM k Char) (f : α → α) + (j : Fin k) := + ∀ (x : α) (views : Fin k → TapeView), + (views j = TapeView.ofEnc x) → + tm.eval_struct views = .some (Function.update views j (TapeView.ofEnc (f x))) + +/-- TODO document -/ +@[expose] +public def computes_function_read_update {k : ℕ} + {α : Type} [StrEnc α] + (tm : MultiTapeTM k Char) (f : α → TapeView → TapeView) + (i j : Fin k) := + ∀ (x : α) (views : Fin k → TapeView), + ((views i).current = StrEnc.toData x) → + tm.eval_struct views = .some (Function.update views j (f x (views j))) + +/-- TODO document -/ +@[expose] +public def computes_function_read_update' {k : ℕ} + {α β : Type} [StrEnc α] [StrEnc β] + (tm : MultiTapeTM k Char) (f : α → β → β) + (i j : Fin k) := + ∀ (x : α) (y : β) (views : Fin k → TapeView), + ((views i).current = StrEnc.toData x) → + views j = TapeView.ofEnc y → + tm.eval_struct views = .some (Function.update views j (TapeView.ofEnc (f x y))) + +/-- TODO document -/ +@[expose] +public def computes_function_read_read_update {k : ℕ} + {α β : Type} [StrEnc α] [StrEnc β] + (tm : MultiTapeTM k Char) (f : α → β → TapeView → TapeView) + (i j r : Fin k) := + ∀ (x : α) (y : β) (views : Fin k → TapeView), + ((views i).current = StrEnc.toData x) → + ((views j).current = StrEnc.toData y) → + tm.eval_struct views = .some (Function.update views r (f x y (views r))) + +/-- TODO document -/ +@[expose] +public def computes_function_read_read_update' {k : ℕ} + {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] + (tm : MultiTapeTM k Char) (f : α → β → γ → γ) + (i j r : Fin k) := + ∀ (x : α) (y : β) (z : γ) (views : Fin k → TapeView), + ((views i).current = StrEnc.toData x) → + ((views j).current = StrEnc.toData y) → + views r = TapeView.ofEnc z → + tm.eval_struct views = .some (Function.update views r (TapeView.ofEnc (f x y z))) + + +/-- TODO document -/ +@[expose] +public def computes_function_read_replace {k : ℕ} + {α β : Type} [StrEnc α] [StrEnc β] + (tm : MultiTapeTM k Char) + (f : α → β) + (i j : Fin k) := + computes_function_read_update' tm (fun d _ => f d) i j + +-- /-- Turing machine `tm` computes a function on data from tape `i` and pushes data to the +-- list on tape `j`. -/ +-- @[expose] +-- public def computes_function_read_push {k : ℕ} +-- {α β : Type} [StrEnc α] [StrEnc β] +-- (tm : MultiTapeTM k Char) +-- (f : α → β) +-- (i j : Fin k) := +-- computes_function_read_update tm (fun d tv => tv.pushList (StrEnc.toData (f d))) i j + +/-- TODO document -/ +@[expose] +public def computes_function_read_push {k : ℕ} + {α β : Type} [StrEnc α] [StrEnc β] + (tm : MultiTapeTM k Char) + (f : α → β) + (i j : Fin k) := + computes_function_read_update tm (fun d tv => tv.pushList (StrEnc.toData (f d))) i j + +-- If the list is heterogeneous, use β = Data +/-- TODO document -/ +@[expose] +public def computes_function_read_push' {k : ℕ} + {α β : Type} [StrEnc α] [StrEnc β] + (tm : MultiTapeTM k Char) + (f : α → β) + (i j : Fin k) := + computes_function_read_update' tm (fun d ls => (f d) :: ls) i j + +/-- TODO document -/ +@[expose] +public def computes_function_read_read_push {k : ℕ} + {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] + (tm : MultiTapeTM k Char) + (f : α → β → γ) + (i j s : Fin k) := + computes_function_read_read_update tm + (fun x y tv => tv.pushList (StrEnc.toData (f x y))) i j s + +/-- TODO document -/ +@[expose] +public def computes_function_read_read_push' {k : ℕ} + {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] + (tm : MultiTapeTM k Char) + (f : α → β → γ) + (i j s : Fin k) := + computes_function_read_read_update' tm + (fun x y (ls : List Data) => StrEnc.toData (f x y) :: ls) i j s + + +/-- Turing machine `tm` updates the head of tape `i`. -/ +public def computes_function_head_update {k : ℕ} + {α : Type} [StrEnc α] + (tm : MultiTapeTM k Char) (f : α → α) + (i : Fin k) := + computes_function_update tm + (fun ls => match ls with + | h :: tail => (f h) :: tail + | [] => []) i + +@[simp, grind =>] +public theorem computes_function_seq₁ {k : ℕ} + {α β : Type} [StrEnc α] [StrEnc β] + {tm₁ tm₂ : MultiTapeTM k Char} {f₁ : α → β} {f₂ : β → β} + {i j : Fin k} + (h_comp₁ : computes_function_read_push tm₁ f₁ i j) + (h_comp₂ : computes_function_head_update tm₂ f₂ j) : + computes_function_read_push (tm₁;ₜ tm₂) (fun x => f₂ (f₁ x)) i j := by sorry + +@[simp, grind =>] +public theorem computes_function_seq₂ {k : ℕ} + {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] + {tm₁ tm₂ : MultiTapeTM k Char} {f₁ : α → β → γ} {f₂ : γ → γ} + {i j r : Fin k} + (h_comp₁ : computes_function_read_read_push tm₁ f₁ i j r) + (h_comp₂ : computes_function_head_update tm₂ f₂ r) : + computes_function_read_read_push (tm₁;ₜ tm₂) (fun x y => f₂ (f₁ x y)) i j r := by sorry + + +@[grind =>] +public theorem computes_function_read_read_push_swap {k : ℕ} + {α β γ : Type} [StrEnc α] [StrEnc β] [StrEnc γ] + {tm : MultiTapeTM k Char} {f : α → β → γ} + {i j r : Fin k} + (h : computes_function_read_read_push tm f i j r) : + computes_function_read_read_push tm (fun x y => f y x) j i r := by sorry + + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Routines/While.lean b/Cslib/Computability/Machines/MultiTapeTuring/Routines/While.lean new file mode 100644 index 0000000000..d80512a953 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Routines/While.lean @@ -0,0 +1,33 @@ +/- +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.MultiTapeTuring.StructuralMachines +public import Cslib.Computability.Machines.MultiTapeTuring.TapeView + +namespace Turing +namespace Routines + +/-- Repeatedly run a sub routine as long as the current item on tape `i` is equal to a given +encoding. +-/ +public def doWhileEq {k : ℕ} (d : Data) (i : Fin k) (tm : MultiTapeTM k Char) : + MultiTapeTM k Char := sorry + +-- TODO +-- public theorem doWhileEq.eval_struct {k : ℕ} {d : Data} {i : Fin k} {tm : MultiTapeTM k Char} +-- {h_halts : ∀ views, tm.HaltsOn (TapeView.toBiTape ∘ views)} +-- {views : Fin k → TapeView} +-- (n : ℕ) +-- (h_exists : ((tm.eval_struct · sorry)^[n] views i).current = d) +-- (h_min : ∀ n' < n, ((tm.eval_struct sorry)^[n'] views i).current ≠ d) : +-- (doWhileEq d i tm).eval_struct views = .some ((tm.eval_struct sorry)^[n] views) := by +-- sorry + + +end Routines +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/Satisfiability.lean b/Cslib/Computability/Machines/MultiTapeTuring/Satisfiability.lean new file mode 100644 index 0000000000..80e2dbc3b8 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/Satisfiability.lean @@ -0,0 +1,219 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.TapeView +public import Cslib.Computability.Machines.MultiTapeTuring.StructuralMachines +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Navigation +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Copy +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.ListIteration +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed + +namespace Turing + +namespace Satisfiability + +/-- TODO document -/ +public abbrev Var := ℕ + +/-- TODO document -/ +public inductive Literal where + | pos (v : Var) + | neg (v : Var) + +public instance : StrEnc Literal where + toData + | Literal.pos v => StrEnc.toData [0, v] + | Literal.neg v => StrEnc.toData [1, v] + +/-- TODO document -/ +public abbrev Clause := List Literal + +/-- TODO document -/ +public abbrev Formula := List Clause + +/-- TODO document -/ +public abbrev Assignments := List Var + +/-- TODO document -/ +public inductive SATInput where + | mk (formula : Formula) (assignment : Assignments) + +public instance : StrEnc SATInput where + toData + | SATInput.mk f a => Data.list [StrEnc.toData f, StrEnc.toData a] + +@[simp] +lemma SatInput_toData (formula : Formula) (assignments : Assignments) : + StrEnc.toData (SATInput.mk formula assignments) = + Data.list [StrEnc.toData formula, StrEnc.toData assignments] := by + simp [StrEnc.toData] + +@[simp] +lemma Literal_toData (lit : Literal) : + StrEnc.toData lit = Data.list ( + match lit with + | Literal.pos v => [StrEnc.toData 0, StrEnc.toData v] + | Literal.neg v => [StrEnc.toData 1, StrEnc.toData v]) := by + match lit with + | Literal.pos v => rfl + | Literal.neg v => rfl + +/-- Evaluate a literal given a list of positive-variable assignments. -/ +public def evalLiteral (a : Assignments) : Literal → Bool + | Literal.pos v => a.contains v + | Literal.neg v => !(a.contains v) + +/-- Evaluate a clause (disjunction of literals). -/ +public def evalClause (a : Assignments) (c : Clause) : Bool := + c.any (evalLiteral a) + +/-- Evaluate a formula (conjunction of clauses). -/ +public def evalFormula (a : Assignments) (f : Formula) : Bool := + f.all (evalClause a) + +open Routines + + +/- +A Turing machine that decides satisfiability given a `SATInput` value on tape 0. +Uses 5 tapes: +- Tape 0: the input (formula and assignment) +- Tape 1: the assignment (copied from input) +- Tape 2: intermediate boolean results + +The algorithm: +1. Copy the assignment to tape 1 +2. For all clauses, check that there exists some literal that is satisfied +3. Clean up and leave the result on tape 2 +-/ + + +-- TODO problem is that we need to leave the tape as we started! + + +-- TODO extend this to any inductive type +/-- TODO document -/ +public def case_literal {k : ℕ} + (pos neg : MultiTapeTM k Char) + (i : Fin k) : + MultiTapeTM k Char := + atLeft i ( + -- Navigate to ctor index of literal (first element of Data.list) + toElem 0 i;ₜ + -- Dispatch on ctor index + case_nat i + [ -- positive literal (ctorIdx=0): skip to var, run `pos` + outOfList i;ₜ toElem 1 i;ₜ pos;ₜ outOfList i, + -- negative literal (ctorIdx=1): skip to var, run `neg` + outOfList i;ₜ toElem 1 i;ₜ neg;ₜ outOfList i + ]) + +-- TODO why does the simp linter complain here? +public lemma case_literal.computes_fun {k : ℕ} + {β γ : Type} [StrEnc β] [StrEnc γ] + (pos neg : MultiTapeTM k Char) + {i j r : Fin k} + (h_inj : [i, j, r].get.Injective) + {f_pos f_neg : Var → β → γ} + (h_comp_pos : computes_function_read_read_push pos f_pos i j r) + (h_comp_neg : computes_function_read_read_push neg f_neg i j r) : + computes_function_read_read_push + (case_literal pos neg i) + (fun lit x => match lit with + | Literal.pos v => f_pos v x + | Literal.neg v => f_neg v x) + i j r := by + intro lit x views h_lit h_lit_head + have h_neq : i ≠ r := by + exact Function.Injective.ne h_inj (show (0 : Fin 3) ≠ 2 by decide) + have h_ne' : i ≠ j := by + exact Function.Injective.ne h_inj (show (0 : Fin 3) ≠ 1 by decide) + match h : lit with + | Literal.pos v => + simp_all [h_comp_pos v x, case_literal, h_neq.symm, h_ne'.symm] + | Literal.neg v => + simp_all [h_comp_neg v x, case_literal, h_neq.symm, h_ne'.symm] + +-- TODO why does the simp linter complain here? +public lemma case_literal.computes_fun' {k : ℕ} + {β γ : Type} [StrEnc β] [StrEnc γ] + (pos neg : MultiTapeTM k Char) + {i j r : Fin k} + (h_inj : [i, j, r].get.Injective) + {f_pos f_neg : Var → β → γ} + (h_comp_pos : computes_function_read_read_push' pos f_pos i j r) + (h_comp_neg : computes_function_read_read_push' neg f_neg i j r) : + computes_function_read_read_push' + (case_literal pos neg i) + (fun lit x => match lit with + | Literal.pos v => f_pos v x + | Literal.neg v => f_neg v x) + i j r := by + intro lit x ls views h_lit h_x h_ls + have h_neq : i ≠ r := Function.Injective.ne h_inj (show (0 : Fin 3) ≠ 2 by decide) + have h_ne' : i ≠ j := Function.Injective.ne h_inj (show (0 : Fin 3) ≠ 1 by decide) + match h : lit with + | Literal.pos v => + simp_all [h_comp_pos v x ls, case_literal, h_neq.symm, h_ne'.symm] + | Literal.neg v => + simp_all [h_comp_neg v x ls, case_literal, h_neq.symm, h_ne'.symm] + +/-- Check if literal on tape 0 is satisfied by assignment on tape 1 and store result +on tape 2. -/ +def sat_verify_eval_literal : MultiTapeTM 5 Char := + case_literal + (contains 1 0 2) + (contains 1 0 2;ₜ negateBool 2) + 0 + +lemma sat_verify_eval_literal.computes_fun : + computes_function_read_read_push + sat_verify_eval_literal + (fun lit ass => evalLiteral ass lit) + 0 1 2 := by + let h_pos := computes_function_read_read_push_swap + (contains.computes_fun (α := Var) (k := 5) (i := 1) (j := 0) (result := 2) (by decide)) + let h_neg := computes_function_seq₂ h_pos negateBool.computes_head_update + exact case_literal.computes_fun (β := Assignments) (γ := Bool) _ _ (by decide) h_pos h_neg + +def sat_verify_core : MultiTapeTM 5 Char := + all_list (any_list sat_verify_eval_literal 0 2) 0 2 + +lemma sat_verify_core_semantics : + computes_function_read_read_push + sat_verify_core + (fun formula assignments => evalFormula assignments formula) + 0 1 2 := by + unfold sat_verify_core evalFormula evalClause evalLiteral + exact all_list.computes_fun_twoary (by decide) + (any_list.computes_fun_twoary (by decide) sat_verify_eval_literal.computes_fun) + + +/-- TODO document -/ +public def sat_verify : MultiTapeTM 5 Char := + -- Navigate to assignments (arg 1) and copy to tape 1 + -- toElem 1 0;ₜ copyEnc 0 1;ₜ outOfList 0;ₜ + atElem 1 0 (copyEnc 0 1);ₜ + -- Navigate to formula (arg 0) + atElem 0 0 sat_verify_core;ₜ + replace (Data.list []) 1 + +public theorem sat_verify.computes_fun + {views : Fin 5 → TapeView} + (h_input : (views 0).current = StrEnc.toData (SATInput.mk formula assignments)) + (h_second_empty : views 1 = TapeView.empty) : + sat_verify.eval_struct views = some (Function.update views 2 + ((views 2).pushList (StrEnc.toData (evalFormula assignments formula)))) := by + simp [sat_verify, h_input, sat_verify_core_semantics formula assignments, TapeView.setHeadPosOf] + grind + +end Satisfiability + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/SequentialCombinator.lean b/Cslib/Computability/Machines/MultiTapeTuring/SequentialCombinator.lean new file mode 100644 index 0000000000..8b2f7652a9 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/SequentialCombinator.lean @@ -0,0 +1,64 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +import Cslib.Foundations.Data.BiTape +import Cslib.Foundations.Data.RelatesInSteps + +public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding + +namespace Turing + +namespace MultiTapeTM + +variable [Inhabited Symbol] [Fintype Symbol] +variable {k : ℕ} + +/-- +Sequential combination of Turing machines. Runs `tm₁` and then `tm₂` on the resulting tapes +(if the first one halts). +-/ +public def seq (tm₁ tm₂ : MultiTapeTM k Symbol) : MultiTapeTM k Symbol := sorry + +@[simp] +public theorem seq_eval + (tm₁ tm₂ : MultiTapeTM k Symbol) + (tapes₀ : Fin k → BiTape Symbol) : + (seq tm₁ tm₂).eval tapes₀ = + tm₁.eval tapes₀ >>= fun tape₁ => tm₂.eval tape₁ := by + sorry + +@[simp, grind =] +public theorem seq_eval_list + {tm₁ tm₂ : MultiTapeTM k (WithSep Symbol)} + {tapes₀ : Fin k → List (List Symbol)} : + (seq tm₁ tm₂).eval_list tapes₀ = + tm₁.eval_list tapes₀ >>= fun tape₁ => tm₂.eval_list tape₁ := by + sorry + +public theorem seq_associative + (tm₁ tm₂ tm₃ : MultiTapeTM k Symbol) + (tapes₀ : Fin k → List (List Symbol)) : + (seq (seq tm₁ tm₂) tm₃).eval = (seq tm₁ (seq tm₂ tm₃)).eval := by + sorry + +@[simp, grind =>] +public theorem seq_haltsOn_of_haltsOn + (tm₁ tm₂ : MultiTapeTM k Symbol) (h_halts₁ : ∀ t, tm₁.HaltsOn t) (h_halts₂ : ∀ t, tm₂.HaltsOn t) : + ∀ t, (seq tm₁ tm₂).HaltsOn t := by + sorry + +/-- +Sequential combination of Turing machines. +-/ +infixl:90 ";ₜ" => seq + + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/StructuralMachines.lean b/Cslib/Computability/Machines/MultiTapeTuring/StructuralMachines.lean new file mode 100644 index 0000000000..efbd03f792 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/StructuralMachines.lean @@ -0,0 +1,292 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.TapeView +public import Cslib.Computability.Machines.MultiTapeTuring.SequentialCombinator +public import Mathlib.Data.PFun + +namespace Turing + +-- ═══════════════════════════════════════════════════════════════════════════ +-- eval_struct +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- Evaluate a Turing machine on structured tape views. + Converts `TapeView`s to `BiTape`s via `toBiTape`, runs `eval`, + and converts the result back to `TapeView`s. + + This is defined as a noncomputable opaque function; its behavior + is specified by the `@[simp]` lemmas for each TM routine. -/ +@[expose] +public def MultiTapeTM.eval_struct + (tm : MultiTapeTM k Char) (views : Fin k → TapeView) : + Part (Fin k → TapeView) := + tm.eval (TapeView.toBiTape ∘ views) >>= (TapeView.ofBiTapes? ·) + +/-- The Turing machine `tm` eventually halts starting from any initial TapeView and +the tapes are all a valid encodings of TapeView. -/ +@[expose] +public def AlwaysHaltsOnStruct (tm : MultiTapeTM k Char) : Prop := + ∀ views, (tm.eval_struct views).Dom + +@[expose] +public def MultiTapeTM.eval_struct_tot + (tm : MultiTapeTM k Char) (h_halts : AlwaysHaltsOnStruct tm) (views : Fin k → TapeView) : + Fin k → TapeView := + (tm.eval_struct views).get (h_halts views) + +-- TODO clean up (AI) +public theorem MultiTapeTM.eval_of_eval_struct + {tm : MultiTapeTM k Char} {views views' : Fin k → TapeView} + (h_eval_struct : tm.eval_struct views = .some views') : + tm.eval (TapeView.toBiTape ∘ views) = .some (TapeView.toBiTape ∘ views') := by + unfold eval_struct at h_eval_struct + simp only [Part.bind_eq_bind] at h_eval_struct + have h_mem := h_eval_struct ▸ Part.mem_some _ + rw [Part.mem_bind_iff] at h_mem + obtain ⟨tapes, h_eval, h_of⟩ := h_mem + rw [Part.eq_some_iff.mpr h_eval]; congr 1 + have h_of' : TapeView.ofBiTapes? tapes = some views' := by + rwa [Part.mem_coe] at h_of + simp only [TapeView.ofBiTapes?] at h_of' + split at h_of' + · rename_i h_all + simp only [Option.some.injEq] at h_of' + ext i; simp only [Function.comp_apply] + rw [← congr_fun h_of' i, TapeView.ofBiTape_get_toBiTape] + · simp at h_of' + +namespace Routines + +-- ═══════════════════════════════════════════════════════════════════════════ +-- Primitives +-- ═══════════════════════════════════════════════════════════════════════════ + +variable {Symbol : Type} [Inhabited Symbol] [Fintype Symbol] +variable {k : ℕ} + +/-- TODO document -/ +public def noop : MultiTapeTM k Symbol := sorry + +@[simp] +public theorem noop.eval {tapes : Fin k → BiTape Char} : + noop.eval tapes = some tapes := by sorry + +@[simp] +public theorem noop.eval_struct {views : Fin k → TapeView} : + noop.eval_struct views = some views := by sorry + +/-- TODO document -/ +public def right (i : Fin k) : MultiTapeTM k Char := sorry + +@[simp] +public theorem right.eval {i : Fin k} {tapes : Fin k → BiTape Char} : + (right i).eval tapes = .some + (Function.update tapes i (tapes i).move_right) := by sorry + +@[grind =>] +public lemma right.haltsOn {i : Fin k} : ∀ t, (right i).HaltsOn t := by simp + +@[simp] +public lemma right_eval_struct {k : ℕ} {i : Fin k} {views : Fin k → TapeView} : + (right i).eval_struct views = + if h_left : (views i).headPos = .leftEnd then + Part.some (Function.update views i ( + if h_empty : (views i).current = Data.list [] then + (views i).toRightEnd + else + (views i).appendPath 0 (by simp [h_empty]))) + else + if let some (idx : ℕ) := (views i).path.getLast? then + Part.some (Function.update views i ( + if h_next : ((views i).parent.current.atPath [idx.succ]).isSome then + (views i).parent.appendPath' idx.succ h_next + else + (views i).parent.toRightEnd)) + else + Part.none -- not an encoding of Data, we are one cell to the right of it. + := by + by_cases h_left : (views i).headPos = .leftEnd + · let effect := + if h_empty : (views i).current = .list [] then + (views i).toRightEnd + else + (views i).appendPath 0 (by simp [h_empty]) + have h : Function.update (TapeView.toBiTape ∘ views) i (views i).toBiTape.move_right = + fun j => ((Function.update views i effect) j).toBiTape := by + ext1 j + by_cases h_ij : i = j + · subst h_ij + simp only [effect, Function.update_self, TapeView.appendPath] + by_cases h_empty : (views i).current = .list [] + · simp [h_empty, h_left] + · simp [h_empty, h_left] + · have : j ≠ i := by aesop + simp [this] + simp [h, TapeView.ofBiTapes?, MultiTapeTM.eval_struct, effect, h_left] + · cases h_last : (views i).path.getLast? with + | none => + simp [h_left] + have h_path : (views i).path = [] := by + cases h : (views i).path <;> simp_all [List.getLast?] + have h_encodedPos := TapeView.encodedPos_of_path_eq_nil_right (views i) h_path + (HeadPos.eq_rightEnd_of_ne_leftEnd h_left) + -- Depends on ofBiTape? (sorry'd) + sorry + | some idx => + by_cases h_next : ((views i).parent.current.atPath [idx.succ]).isSome + · simp only [h_next, h_left, ↓reduceDIte] + have := TapeView.toBiTape_comp_update_move_right + (views := views) (i := i) + (by simp [TapeView.parent, TapeView.appendPath']) + (TapeView.encodedPos_next_sibling_succ _ h_last + (HeadPos.eq_rightEnd_of_ne_leftEnd h_left) h_next) + simp [MultiTapeTM.eval_struct, right.eval, this, TapeView.ofBiTapes?] + · simp only [h_next, h_left, ↓reduceDIte, Bool.false_eq_true] + have := TapeView.toBiTape_comp_update_move_right + (views := views) (i := i) + (by simp [TapeView.parent]) + (TapeView.encodedPos_last_child_succ _ h_last + (HeadPos.eq_rightEnd_of_ne_leftEnd h_left) h_next) + simp [MultiTapeTM.eval_struct, right.eval, this, TapeView.ofBiTapes?] + + +/-- TODO document -/ +public def left (i : Fin k) : MultiTapeTM k Char := sorry + +@[simp] +public theorem left.eval {i : Fin k} {tapes : Fin k → BiTape Char} : + (left i).eval tapes = .some + (Function.update tapes i (tapes i).move_left) := by sorry + +@[grind =>] +public lemma left.haltsOn {i : Fin k} : ∀ t, (left i).HaltsOn t := by simp + +/-- TODO document -/ +public def write (c : Option Char) (i : Fin k) : MultiTapeTM k Char := sorry + +@[simp] +public theorem write.eval {c : Option Char} {i : Fin k} {tapes : Fin k → BiTape Char} : + (write c i).eval tapes = .some + (Function.update tapes i ((tapes i).write c)) := by sorry + +/-- TODO document -/ +public def if_eq (c : Char) (i : Fin k) (tm₁ tm₂ : MultiTapeTM k Char) : + MultiTapeTM k Char := sorry + +@[simp] +public theorem if_eq.eval {c : Char} {i : Fin k} {tm₁ tm₂ : MultiTapeTM k Char} + {tapes : Fin k → BiTape Char} : + (if_eq c i tm₁ tm₂).eval tapes = + if (tapes i).head = some c then (tm₁.eval tapes) else (tm₂.eval tapes) := by sorry + +@[simp] +public theorem if_eq_left_eval_struct {i : Fin k} {tm₁ tm₂ : MultiTapeTM k Char} + {views : Fin k → TapeView} : + (if_eq '(' i tm₁ tm₂).eval_struct views = + if (views i).headPos = .leftEnd then tm₁.eval_struct views else tm₂.eval_struct views := by + sorry -- TODO prove by AI + +@[simp] +public theorem if_eq_right_eval_struct {i : Fin k} {tm₁ tm₂ : MultiTapeTM k Char} + {views : Fin k → TapeView} : + (if_eq ')' i tm₁ tm₂).eval_struct views = + if (views i).headPos = .rightEnd then tm₁.eval_struct views else tm₂.eval_struct views := by + sorry -- TODO prove by AI + +/-- TODO document -/ +public def while_eq (c : Option Char) (i : Fin k) (tm : MultiTapeTM k Char) : + MultiTapeTM k Char := sorry + +@[simp] +public theorem while_eq.eval' + (c : Option Char) (i : Fin k) + (tm : MultiTapeTM k Char) + (h_halts : ∀ t, tm.HaltsOn t) + (tapes : Fin k → BiTape Char) : + (while_eq c i tm).eval tapes = + ⟨∃ n, (((tm.eval_tot h_halts)^[n] tapes) i).head != c, + fun h => ((tm.eval_tot h_halts)^[Nat.find h] tapes)⟩ := by sorry + +public theorem while_eq.eval + {c : Option Char} {i : Fin k} + {tm : MultiTapeTM k Char} + {h_halts : ∀ t, tm.HaltsOn t} + {tapes : Fin k → BiTape Char} + (n : ℕ) + (h_exists : ((tm.eval_tot h_halts)^[n] tapes i).head ≠ c) + (h_min : ∀ n' < n, ((tm.eval_tot h_halts)^[n'] tapes i).head = c) : + (while_eq c i tm).eval tapes = (tm.eval_tot h_halts)^[n] tapes := by sorry + +/-- TODO document -/ +public def while_neq (c : Option Char) (i : Fin k) (tm : MultiTapeTM k Char) : + MultiTapeTM k Char := sorry + +@[simp] +public theorem while_neq.eval + (c : Option Char) (i : Fin k) + (tm : MultiTapeTM k Char) + (h_halts : ∀ t, tm.HaltsOn t) + (tapes : Fin k → BiTape Char) : + (while_neq c i tm).eval tapes = + ⟨∃ n, (((tm.eval_tot h_halts)^[n] tapes) i).head == c, + fun h => ((tm.eval_tot h_halts)^[Nat.find h] tapes)⟩ := by sorry + +public theorem while_neq.eval' + {c : Option Char} {i : Fin k} + {tm : MultiTapeTM k Char} + {h_halts : ∀ t, tm.HaltsOn t} + {tapes : Fin k → BiTape Char} + (n : ℕ) + (h_exists : (((tm.eval_tot h_halts)^[n] tapes) i).head == c) + (h_min : ∀ n' < n, (((tm.eval_tot h_halts)^[n'] tapes) i).head ≠ c) : + (while_neq c i tm).eval tapes = ((tm.eval_tot h_halts)^[n] tapes) := by sorry + + +-- ═══════════════════════════════════════════════════════════════════════════ +-- eval_struct lemmas: Compositionality +-- ═══════════════════════════════════════════════════════════════════════════ + +@[simp] +public lemma seq_eval_struct {tm₁ tm₂ : MultiTapeTM k Char} + {views : Fin k → TapeView} : + (tm₁;ₜ tm₂).eval_struct views = + (tm₁.eval_struct views).bind tm₂.eval_struct := by sorry + + +-- ═══════════════════════════════════════════════════════════════════════════ +-- Function.update utilities +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- Sort nested `Function.update` by index: larger indices go outermost. -/ +public theorem Function.update_sort {α : Type*} [DecidableEq α] [LinearOrder α] + {β : Type*} {f : α → β} {a b : α} {v w : β} (h : b < a) : + Function.update (Function.update f a v) b w = + Function.update (Function.update f b w) a v := + Function.update_comm (ne_of_gt h) v w f + +@[simp] +public theorem Function.update_update_update_of_ne {α β : Type*} [DecidableEq α] + {f : α → β} + {i j : α} (h : i ≠ j) (x y z : β) : + Function.update (Function.update (Function.update f i x) j y) i z = + Function.update (Function.update f j y) i z := by + simp [Function.update_comm h, Function.update_idem] + +@[simp] +public theorem Function.update_redundant {α : Type*} [DecidableEq α] + {β : Type*} {f : α → β} {i j : α} {v : β} (h : i ≠ j) : + Function.update (Function.update f i v) j (f j) = + Function.update f i v := by + grind + + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/SuccRoutine.lean b/Cslib/Computability/Machines/MultiTapeTuring/SuccRoutine.lean new file mode 100644 index 0000000000..0ed3fc41c4 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/SuccRoutine.lean @@ -0,0 +1,60 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +import Cslib.Foundations.Data.BiTape +import Cslib.Foundations.Data.RelatesInSteps + +public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.WithTapes + +import Mathlib.Data.Nat.Bits + +namespace Turing + +namespace Routines + +def succ₀ : MultiTapeTM 1 (WithSep OneTwo) where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp] +lemma succ₀_eval_list {tapes : Fin 1 → List (List OneTwo)} : + succ₀.eval_list tapes = .some (Function.update tapes 0 + ((dya (dya_inv ((tapes 0).headD [])).succ) :: (tapes 0).tail)) := by + sorry + +/-- +A Turing machine that increments the head of tape `i` by one (in dyadic encoding). +Pushes zero if the tape is empty. -/ +public def succ {k : ℕ} (i : Fin k) : MultiTapeTM k (WithSep OneTwo) := + succ₀.with_tapes [i].get (by intro x y; grind) + +@[simp] +public theorem succ_eval_list {k : ℕ} {i : Fin k} {tapes : Fin k → List (List OneTwo)} : + (succ i).eval_list tapes = .some (Function.update tapes i + ((dya (dya_inv ((tapes i).headD [])).succ) :: (tapes i).tail)) := by + simpa [succ] using apply_updates_function_update (by intro x y; grind) + +-- lemma succ₀_evalWithStats_list {n : ℕ} {ls : List (List OneTwo)} : +-- succ₀.evalWithStats_list [(dya n) :: ls].get = +-- .some ( +-- [(dya n.succ) :: ls].get, +-- -- this depends on if we have overflow on the highest dyadic character or not. +-- if (dya n.succ).length = (dya n).length then +-- [⟨0, (dya n).length, 0, by omega⟩].get +-- else +-- [⟨-1, (dya n).length, -1, by omega⟩].get) := by +-- sorry + + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/TapeExtension.lean b/Cslib/Computability/Machines/MultiTapeTuring/TapeExtension.lean new file mode 100644 index 0000000000..7e414cdb7d --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/TapeExtension.lean @@ -0,0 +1,72 @@ +/- +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.MultiTapeTuring.Basic + +namespace Turing + +variable [Inhabited Symbol] [Fintype Symbol] + +/-- Extend a Turing machine to work with more tapes. +The added tapes are not acted upon. -/ +public def MultiTapeTM.extend {k₁ k₂ : ℕ} (h_le : k₁ ≤ k₂) + (tm : MultiTapeTM k₁ Symbol) : MultiTapeTM k₂ Symbol where + State := tm.State + stateFintype := tm.stateFintype + q₀ := tm.q₀ + tr := fun q syms => match tm.tr q (fun i => syms ⟨i, by omega⟩) with + | (stmts, q') => + (fun i => if h : i < k₁ then stmts ⟨i, h⟩ else default, q') + +/-- +Restrict a sequence of tapes to the first `k'` tapes. +-/ +@[simp] +public abbrev tapes_take + {γ : Type} + (tapes : Fin k → γ) + (k' : ℕ) + (h_le : k' ≤ k) + (i : Fin k') : γ := + tapes ⟨i, by omega⟩ + +@[simp] +public lemma Function.update_tapes_take + {γ : Type} + (k : ℕ) + {k' : ℕ} + {h_le : k' ≤ k} + {tapes : Fin k → γ} + {p : Fin k'} + {v : γ} : + Function.update (tapes_take tapes k' h_le) p v = + tapes_take (Function.update tapes ⟨p, by omega⟩ v) k' h_le := by + sorry + +/-- +Extend a sequence of tapes by adding more tapes at the end. +Ignores the first `k₁` tapes of `extend_by` and uses the rest. +-/ +@[simp] +public abbrev tapes_extend_by + {γ : Type} + {k₁ k₂ : ℕ} + (tapes : Fin k₁ → γ) + (extend_by : Fin k₂ → γ) + (i : Fin k₂) : γ := + if h : i < k₁ then tapes ⟨i, h⟩ else extend_by i + +@[simp, grind =] +public lemma MultiTapeTM.extend_eval {k₁ k₂ : ℕ} (h_le : k₁ ≤ k₂) + (tm : MultiTapeTM k₁ Symbol) + {tapes : Fin k₂ → BiTape Symbol} : + (tm.extend h_le).eval tapes = + (tm.eval (tapes ⟨·, by omega⟩)).map (fun tapes' => tapes_extend_by tapes' tapes) := by + sorry + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/TapeView.lean b/Cslib/Computability/Machines/MultiTapeTuring/TapeView.lean new file mode 100644 index 0000000000..691fb2ad19 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/TapeView.lean @@ -0,0 +1,745 @@ +/- +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.MultiTapeTuring.Data + +namespace Turing + +-- ═══════════════════════════════════════════════════════════════════════════ +-- TapeView +-- ═══════════════════════════════════════════════════════════════════════════ + +/-- Head positioning. -/ +public inductive HeadPos where + /-- The head is positioned an the opening `(` -/ + | leftEnd + /-- The head is positioned at the closing `)`. -/ + | rightEnd + deriving DecidableEq + +public lemma HeadPos.eq_rightEnd_of_ne_leftEnd {hp : HeadPos} + (h : ¬hp = .leftEnd) : hp = .rightEnd := by + cases hp <;> simp_all + +/-- A structured view of a tape that contains an encoding of `Data`. +- `data`: the content present on the tape, encoding using `Data.enc`. +- `path`: a navigation path into the `Data` value, pointing to the "current" value. +- `headPos`: the position of the head, either at the left or right end of the current value. +-/ +@[ext] +public structure TapeView where + /-- The `Data` value on the tape. -/ + data : Data + /-- Navigation path into the `Data` value. -/ + path : List ℕ + /-- The position of the head, either at the left or right end. -/ + headPos : HeadPos + /-- The path is valid. -/ + h_path : (data.atPath path).isSome + +instance : Inhabited TapeView := ⟨⟨Data.list [], [], .leftEnd, by rfl⟩⟩ + +namespace TapeView + +/-- A tape containing a single Data value with the head at the start. -/ +@[expose] +public abbrev ofData (d : Data) : TapeView := ⟨d, [], .leftEnd, by rfl⟩ + +/-- TODO document -/ +@[expose] +public abbrev ofList (ls : List Data) : TapeView := ofData (Data.list ls) + +/-- An "empty" tape (represented as an empty list), so it is actually not really empty. -/ +@[expose] +public abbrev empty : TapeView := ofList [] + +/-- A tape containing a single typed value with the head at the start. -/ +@[expose] +public abbrev ofEnc {α : Type*} [StrEnc α] (x : α) : TapeView := + ofData (StrEnc.toData x) + +/-- The Data element currently pointed to by the head (at the path + position). Note that this is not tagged `@[simp]` because many + preconditions on simp lemmas use `(views i).current = ...`. + Also note that the head can be at the left or right end of the current value. -/ +@[expose] +public def current (tv : TapeView) : Data := + (tv.data.atPath tv.path).get tv.h_path + +@[simp, grind =] +public lemma current_append {data : Data} {path : List ℕ} {pos : HeadPos} + {h : (data.atPath path).isSome} : + (TapeView.mk data path pos h).current = + (data.atPath path).get h := by simp [current] + +@[simp] +public lemma mk_data_path (tv : TapeView) (h : (tv.data.atPath tv.path).isSome) : + TapeView.mk tv.data tv.path tv.headPos h = tv := by + cases tv; rfl + +-- TODO it looks weird to make that a simp. is it OK? +@[simp, grind =] +public lemma current_rev (tv : TapeView) : + tv.data.atPath tv.path = tv.current := by simp [current] + +@[simp] +public lemma current_atPath_length_sub_one_isSome_of_non_empty (tv : TapeView) + (h_nonempty : ¬ tv.current = .list []) : + (tv.current.atPath [tv.current.toList.length - 1]).isSome := by + sorry + +/-- TODO document -/ +@[expose, simp] +public def parent (tv : TapeView) : TapeView := ⟨tv.data, tv.path.dropLast, tv.headPos, by simp⟩ + +@[expose] +public def parent_n (tv : TapeView) (n : ℕ) : TapeView := + ⟨tv.data, tv.path.take (tv.path.length - n), tv.headPos, by simp⟩ + +@[simp] +public def parent_zero (tv : TapeView) : parent_n tv 0 = tv := by + simp [parent_n] + +-- @[simp] +-- public lemma parent_data (tv : TapeView) : tv.parent.data = tv.data := by +-- unfold parent +-- split <;> simp + +-- @[simp] +-- public lemma parent_path (tv : TapeView) : tv.parent.path = tv.path.dropLast := by +-- unfold parent +-- split <;> grind + +-- @[simp] +-- public lemma parent_headPos (tv : TapeView) : tv.parent.headPos = tv.headPos := by +-- unfold parent +-- split <;> grind + +/-- TODO don't use, I think it is unnatural to keep the headPos -/ +@[expose, simp] +public def appendPath (tv : TapeView) (idx : ℕ) + (h : (tv.current.atPath [idx]).isSome) : TapeView := + ⟨tv.data, tv.path ++ [idx], tv.headPos, by simpa using h⟩ + +/-- Like `appendPath` but always sets `headPos` to `.leftEnd`. +-- TODO rename to appendToPath or consPath or snocPath -/ +@[expose, simp] +public def appendPath' (tv : TapeView) (idx : ℕ) + (h : (tv.current.atPath [idx]).isSome) : TapeView := + ⟨tv.data, tv.path ++ [idx], .leftEnd, by simpa using h⟩ + + +/-- Like `appendPath` but always sets `headPos` to `.leftEnd`. -/ +@[expose, simp] +public def appendPath'' (tv : TapeView) (path : List ℕ) + (h : (tv.current.atPath path).isSome) : TapeView := + ⟨tv.data, tv.path ++ path, .leftEnd, by simpa using h⟩ + +/-- Copy the `headPos` from `tv'` into `tv`, keeping all other fields. -/ +@[expose] +public abbrev setHeadPosOf (tv tv' : TapeView) : TapeView := + ⟨tv.data, tv.path, tv'.headPos, tv.h_path⟩ + +@[simp] +public lemma setHeadPosOf_of_eq (tv tv' : TapeView) (h_eq : tv'.headPos = tv.headPos) : + tv.setHeadPosOf tv' = tv := by + simp [setHeadPosOf, h_eq] + +/-- Return a copy of the `TapeView` with the head positioned at the left end. -/ +@[expose] +public abbrev toLeftEnd (tv : TapeView) : TapeView := + ⟨tv.data, tv.path, .leftEnd, tv.h_path⟩ + +@[simp] +public lemma toLeftEnd_of_leftEnd (tv : TapeView) + (h : tv.headPos = .leftEnd) : tv.toLeftEnd = tv := by + ext <;> simp_all + +/-- Return a copy of the `TapeView` with the head positioned at the right end. -/ +@[expose] +public abbrev toRightEnd (tv : TapeView) : TapeView := + ⟨tv.data, tv.path, .rightEnd, tv.h_path⟩ + +@[simp] +public lemma toRightEnd_of_rightEnd (tv : TapeView) + (h : tv.headPos = .rightEnd) : tv.toRightEnd = tv := by + ext <;> simp_all + +@[simp] +public lemma toLeftEnd_toRightEnd (tv : TapeView) : + tv.toLeftEnd.toRightEnd = tv.toRightEnd := by + ext <;> simp_all + +@[simp] +public lemma toRightEnd_toLeftEnd (tv : TapeView) : + tv.toRightEnd.toLeftEnd = tv.toLeftEnd := by + ext <;> simp_all + +-- /-- simp lemma that says that `(tv.appendPath' n _).parent = tv.toLeftEnd -/ +-- @[simp] +-- public lemma parent_appendPath' (tv : TapeView) (idx : ℕ) +-- (h : (tv.current.atPath [idx]).isSome) : +-- (tv.appendPath' idx h).parent = tv.toLeftEnd := by +-- simp [appendPath', parent, toLeftEnd] + +/-- The position of the head in the encoded version of the + `TapeView`. -/ +@[expose] +public def encodedPos : (tv : TapeView) → ℕ + | ⟨_, [], .leftEnd, _⟩ => 0 + | ⟨d, [], .rightEnd, _⟩ => d.enc.length - 1 + | ⟨.list ds, p :: path, headPos, h_valid⟩ => + have h : p < ds.length := by grind [Data.atPath] + 1 + + ((ds.take p).map fun d => d.enc.length).sum + + encodedPos ⟨ds[p], path, headPos, by grind [Data.atPath]⟩ + termination_by tv => tv.path.length + +@[simp] +public lemma encodedPos_of_path_eq_nil_left (tv : TapeView) + (h_path : tv.path = []) + (h_left : tv.headPos = .leftEnd) : + tv.encodedPos = 0 := by + unfold encodedPos + split <;> simp_all + +@[simp] +public lemma encodedPos_of_path_eq_nil_right (tv : TapeView) + (h_path : tv.path = []) + (h_left : tv.headPos = .rightEnd) : + tv.encodedPos = tv.data.enc.length - 1 := by + unfold encodedPos + split <;> simp_all + +@[simp] +public lemma encodedPos_appendPath (tv : TapeView) (idx : ℕ) + (h : (tv.data.atPath (tv.path ++ [idx])).isSome) : + (TapeView.mk tv.data (tv.path ++ [idx]) .leftEnd h).encodedPos = + tv.encodedPos + 1 + + ((match tv.current with | .list ls => ls.take idx).map fun d : Data => d.enc.length).sum := by + sorry + +public lemma encodedPos_appendPath' (tv : TapeView) (idx : ℕ) + (h_last : tv.path.getLast?.isSome) + (h_left : tv.headPos = .leftEnd) : + tv.encodedPos = tv.parent.encodedPos + 1 + + ((match tv.current with | .list ls => ls.take (tv.path.getLast?.get h_last)).map + fun d : Data => d.enc.length).sum := by + sorry + +/-- Taking one more element adds the next element's encoding length to the sum. -/ +private lemma sum_map_enc_length_take_succ (ds : List Data) (idx : ℕ) (h : idx < ds.length) : + ((ds.take (idx + 1)).map fun d => d.enc.length).sum = + ((ds.take idx).map fun d => d.enc.length).sum + ds[idx].enc.length := by + induction ds generalizing idx with + | nil => simp at h + | cons d ds ih => + cases idx with + | zero => simp + | succ n => + simp only [List.take_succ_cons, List.map_cons, List.sum_cons, List.getElem_cons_succ] + rw [ih n (by simp at h; omega)]; omega + +/-- At rightEnd of the last child, moving one position right reaches the parent's rightEnd. -/ +public lemma encodedPos_last_child_succ : (tv : TapeView) → + (h_last : tv.path.getLast? = some idx) → + (h_right : tv.headPos = .rightEnd) → + (h_no_next : ¬((tv.parent.current.atPath [idx.succ]).isSome)) → + tv.encodedPos + 1 = tv.parent.toRightEnd.encodedPos := by + intro ⟨d, path, headPos, h_valid⟩ + induction path generalizing d headPos with + | nil => intro h_last; simp at h_last + | cons p tail ih => + intro h_last h_right h_no_next + subst h_right + let .list ds := d + cases tail with + | nil => + have h_idx : idx = p := by grind + subst h_idx + have h_p : idx < ds.length := by grind [Data.atPath] + have h_idx_last : idx + 1 ≥ ds.length := by + simp [parent, current, Data.atPath] at h_no_next; omega + have h_sum : ((ds.take idx).map fun d => d.enc.length).sum + ds[idx].enc.length = + (ds.map fun d => d.enc.length).sum := by + have hsplit : ds = ds.take idx ++ ds.drop idx := by simp + conv_rhs => rw [hsplit, List.map_append, List.sum_append] + congr 1 + rw [List.drop_eq_getElem_cons h_p, show idx + 1 = ds.length from by omega, + List.drop_length, List.map_cons, List.map_nil, List.sum_cons, List.sum_nil, Nat.add_zero] + simp only [parent, toRightEnd, show [idx].dropLast = ([] : List ℕ) from rfl, + encodedPos, Data.enc_list, List.length_append, List.length_singleton, + List.length_flatten, List.map_map, List.map_take] + conv_rhs => rw [show (List.length ∘ Data.enc) = (fun d => d.enc.length) from rfl] + rw [← List.map_take] + have := Data.enc_length_pos ds[idx] + omega + | cons r rest => + have h_p : p < ds.length := by grind [Data.atPath] + have h_sub : (ds[p].atPath (r :: rest)).isSome := by grind [Data.atPath] + have h_last' : (r :: rest).getLast? = some idx := by + simpa [List.getLast?_cons_cons] using h_last + have h_drop : (p :: r :: rest).dropLast = p :: (r :: rest).dropLast := by + simp [List.dropLast_cons_of_ne_nil] + conv_lhs => lhs; unfold encodedPos; simp [h_p] + simp only [parent, h_drop] + conv_rhs => rw [toRightEnd]; unfold encodedPos; simp [h_p] + have ih := ih ds[p] .rightEnd h_sub h_last' rfl (by + convert h_no_next using 2; simp [parent, current, h_p, h_drop]) + simp only [parent, toRightEnd] at ih; omega + +/-- At rightEnd of a non-last child, moving right reaches the next sibling's leftEnd. -/ +public lemma encodedPos_next_sibling_succ : (tv : TapeView) → + (h_last : tv.path.getLast? = some idx) → + (h_right : tv.headPos = .rightEnd) → + (h_next : (tv.parent.current.atPath [idx.succ]).isSome) → + tv.encodedPos + 1 = (tv.parent.appendPath' idx.succ h_next).encodedPos + | ⟨.list ds, [p], .rightEnd, h_valid⟩, h_last, _, h_next => by + have h_idx : idx = p := by simp [List.getLast?] at h_last; exact h_last.symm + subst h_idx + have h_p : idx < ds.length := by grind [Data.atPath] + have h_p' : idx + 1 < ds.length := by + simp [parent, current, Data.atPath] at h_next; omega + conv_lhs => lhs; unfold encodedPos; simp [h_p] + simp only [parent, appendPath'] + conv_rhs => unfold encodedPos; simp [h_p']; unfold encodedPos; simp + simp only [← List.map_take] + rw [sum_map_enc_length_take_succ ds idx h_p] + have := Data.enc_length_pos ds[idx]; omega + | ⟨.list ds, p :: r :: rest, .rightEnd, h_valid⟩, h_last, _, h_next => by + have h_p : p < ds.length := by grind [Data.atPath] + have h_sub : (ds[p].atPath (r :: rest)).isSome := by grind [Data.atPath] + have h_last' : (r :: rest).getLast? = some idx := by + simpa [List.getLast?_cons_cons] using h_last + have h_drop : (p :: r :: rest).dropLast = p :: (r :: rest).dropLast := by + simp [List.dropLast_cons_of_ne_nil] + conv_lhs => lhs; unfold encodedPos; simp [h_p] + simp only [parent, h_drop, appendPath'] + conv_rhs => unfold encodedPos; simp [h_p] + exact (encodedPos_next_sibling_succ + ⟨ds[p], r :: rest, .rightEnd, h_sub⟩ h_last' rfl (by + convert h_next using 2; simp [parent, current, h_p, h_drop])) ▸ rfl + termination_by tv => tv.path.length + +/-- The encoding starting at `encodedPos` begins with `current.enc`. -/ +private lemma enc_drop_prefix (tv : TapeView) (h_left : tv.headPos = .leftEnd) : + tv.current.enc <+: tv.data.enc.drop tv.encodedPos := by + match tv with + | ⟨_, [], .leftEnd, h_path⟩ => + simp [current, Data.atPath] + | ⟨d, [], .rightEnd, h_path⟩ => + simp at h_left + | ⟨Data.list ds, p :: path, headPos, h_valid⟩ => + have hp : p < ds.length := by grind [Data.atPath] + have h_path_valid : (ds[p].atPath path).isSome := by grind [Data.atPath] + have ih := enc_drop_prefix ⟨ds[p], path, headPos, h_path_valid⟩ h_left + have h_current : (⟨Data.list ds, p :: path, headPos, h_valid⟩ : TapeView).current = + (⟨ds[p], path, headPos, h_path_valid⟩ : TapeView).current := by + unfold current; simp [Data.atPath, hp] + rw [h_current]; simp only [encodedPos, Data.enc_list] + -- Strip the leading '(' + change _ <+: (['('] ++ (ds.map Data.enc).flatten ++ [')']).drop _ + rw [show ['('] ++ (ds.map Data.enc).flatten ++ [')'] = + '(' :: ((ds.map Data.enc).flatten ++ [')']) from by simp, + show 1 + ((ds.take p).map fun d => d.enc.length).sum + + (⟨ds[p], path, headPos, h_path_valid⟩ : TapeView).encodedPos = + (((ds.take p).map fun d => d.enc.length).sum + + (⟨ds[p], path, headPos, h_path_valid⟩ : TapeView).encodedPos) + 1 from by omega, + List.drop_succ_cons] + -- Split flatten at position p + have h_flatten_eq : (ds.map Data.enc).flatten = + ((ds.take p).map Data.enc).flatten ++ ((ds.drop p).map Data.enc).flatten := by + conv_lhs => rw [← List.take_append_drop p ds] + simp only [List.map_append, List.flatten_append] + have h_sum_eq : ((ds.take p).map fun d => d.enc.length).sum = + ((ds.take p).map Data.enc).flatten.length := by + rw [List.length_flatten, List.map_map]; rfl + rw [h_flatten_eq, List.append_assoc] + rw [show ((ds.take p).map fun d => d.enc.length).sum + + (⟨ds[p], path, headPos, h_path_valid⟩ : TapeView).encodedPos = + ((ds.take p).map Data.enc).flatten.length + + (⟨ds[p], path, headPos, h_path_valid⟩ : TapeView).encodedPos from by omega] + rw [List.drop_length_add_append, + List.drop_eq_getElem_cons hp, List.map_cons, List.flatten_cons, List.append_assoc] + rw [List.drop_append_of_le_length (by + rcases ih with ⟨t, ht⟩ + have h_len := congrArg List.length ht + simp only [List.length_drop, List.length_append] at h_len + have := Data.enc_length_pos (⟨ds[p], path, headPos, h_path_valid⟩ : TapeView).current + omega)] + exact ih.trans (List.prefix_append ..) + termination_by tv.path.length + +-- TODO clean up (ai) +/-- `current.enc` is a slice of `data.enc` starting at `encodedPos`. -/ +public lemma enc_current_slice (tv : TapeView) (h_left : tv.headPos = .leftEnd) + (n : ℕ) (hn : n < tv.current.enc.length) : + tv.data.enc[tv.encodedPos + n]? = some tv.current.enc[n] := by + obtain ⟨suffix, h_suffix⟩ := enc_drop_prefix tv h_left + have h1 : tv.data.enc[tv.encodedPos + n]? = (tv.current.enc ++ suffix)[n]? := by + have := congrArg (·[n]?) h_suffix + simp only [List.getElem?_drop] at this + exact this.symm + rw [h1, List.getElem?_append_left hn, List.getElem?_eq_getElem] + +/-- The rightEnd encodedPos is the leftEnd encodedPos plus current.enc.length - 1. -/ +private lemma encodedPos_toRightEnd : (tv : TapeView) → + tv.toRightEnd.encodedPos = tv.toLeftEnd.encodedPos + (tv.current.enc.length - 1) + | ⟨.list ds, [], _, _⟩ => by + simp [toRightEnd, toLeftEnd, current, Data.atPath] + | ⟨.list ds, p :: path, hp, h_valid⟩ => by + have h_p : p < ds.length := by grind [Data.atPath] + have h_sub : (ds[p].atPath path).isSome := by grind [Data.atPath] + have ih := encodedPos_toRightEnd ⟨ds[p], path, hp, h_sub⟩ + have h_current : (⟨Data.list ds, p :: path, hp, h_valid⟩ : TapeView).current = + (⟨ds[p], path, hp, h_sub⟩ : TapeView).current := by + simp [current, Data.atPath, h_p] + rw [h_current] + simp only [toRightEnd, toLeftEnd] at ih ⊢ + conv_lhs => unfold encodedPos; simp only [h_p, ↓reduceDIte] + conv_rhs => + lhs; unfold encodedPos; simp only [h_p, ↓reduceDIte] + omega + termination_by tv => tv.path.length + +/-- Convert a `TapeView` to the corresponding `BiTape Char`. -/ +@[expose] +public def toBiTape (tv : TapeView) : BiTape Char := + BiTape.move_right^[tv.encodedPos] (BiTape.mk₁ tv.data.enc) + +/-- Moving right on a TapeView's BiTape equals the BiTape of the target TapeView, + given matching data and successor encodedPos. -/ +public lemma toBiTape_move_right_eq (tv target : TapeView) + (h_data : tv.data = target.data) + (h_enc : tv.encodedPos + 1 = target.encodedPos) : + tv.toBiTape.move_right = target.toBiTape := by + simp only [toBiTape, h_data] + rw [← h_enc, Nat.add_comm, Function.iterate_add_apply, Function.iterate_one] + +/-- At leftEnd, the head of the BiTape reads `'('`. -/ +@[simp] +public lemma toBiTape_head_leftEnd (tv : TapeView) + (h_left : tv.headPos = .leftEnd) : + tv.toBiTape.head = some '(' := by + simp only [toBiTape, BiTape.head_iterate_move_right_mk₁] + have h := enc_current_slice tv h_left 0 (Data.enc_length_pos tv.current) + simp only [Nat.add_zero] at h + rw [h]; simp + +/-- At rightEnd, the head of the BiTape reads `')'`. -/ +@[simp] +public lemma toBiTape_head_rightEnd (tv : TapeView) + (h_right : tv.headPos = .rightEnd) : + tv.toBiTape.head = some ')' := by + simp only [toBiTape, BiTape.head_iterate_move_right_mk₁] + have h_pos := encodedPos_toRightEnd tv + have h_right_eq : tv.toRightEnd.encodedPos = tv.encodedPos := by + congr 1; cases tv; simp_all [toRightEnd] + rw [h_right_eq] at h_pos + rw [h_pos] + -- Goal: tv.data.enc[tv.toLeftEnd.encodedPos + (tv.current.enc.length - 1)]? + -- = some ')' + -- Use enc_current_slice with n = tv.current.enc.length - 1 + exact (enc_current_slice tv.toLeftEnd rfl + (tv.toLeftEnd.current.enc.length - 1) + (by have := Data.enc_length_pos tv.toLeftEnd.current; omega)).trans + (by simp [Data.enc_getElem_last]) + +-- TODO clean up (ai) +/-- Checking all chars of `v.enc` starting from the head of `toBiTape tv` is equivalent + to `tv.current = v`. -/ +public lemma ite_enc_condition_iff (tv : TapeView) (h_left : tv.headPos = .leftEnd) (v : Data) : + (∀ n, (h : n < v.enc.length) → + (BiTape.move_right^[n] tv.toBiTape).head = some v.enc[n]) ↔ + tv.current = v := by + have key : ∀ n, (BiTape.move_right^[n] tv.toBiTape).head = + tv.data.enc[tv.encodedPos + n]? := by + intro n + unfold toBiTape + simp [← Function.iterate_add_apply, Nat.add_comm] + simp only [key] + constructor + · intro h_match + have h_eq_chars : ∀ n, (hn_c : n < tv.current.enc.length) → (hn_v : n < v.enc.length) → + tv.current.enc[n] = v.enc[n] := by + intro n hn_c hn_v + have h1 := enc_current_slice tv h_left n hn_c + have h2 := h_match n hn_v + rw [h1] at h2; exact Option.some_injective _ h2 + suffices h : tv.current.enc <+: v.enc ∨ v.enc <+: tv.current.enc by + rcases h with h | h + · exact Data.enc_prefix_free h + · exact (Data.enc_prefix_free h).symm + have h_prefix : ∀ {a b : List Char}, a.length ≤ b.length → + (∀ n, (hn_a : n < a.length) → (hn_b : n < b.length) → a[n] = b[n]) → a <+: b := by + intro a b h_len h_eq + rw [List.prefix_iff_eq_take] + exact List.ext_getElem (by simp; omega) fun n h1 h2 => by + simp only [List.getElem_take]; exact h_eq n (by omega) (by omega) + by_cases h_len : tv.current.enc.length ≤ v.enc.length + · exact Or.inl (h_prefix h_len h_eq_chars) + · exact Or.inr (h_prefix (by omega) fun n h1 h2 => (h_eq_chars n h2 h1).symm) + · intro h_eq; subst h_eq; exact fun n hn => enc_current_slice tv h_left n hn + +/-- At rightEnd, moving left `current.enc.length - 1` and checking `v.enc` is equivalent + to `current = v`. -/ +public lemma ite_enc_condition_right_iff (tv : TapeView) (h_right : tv.headPos = .rightEnd) + (v : Data) : + (∀ n, (h : n < v.enc.length) → + (BiTape.move_right^[n] + (BiTape.move_left^[v.enc.length - 1] tv.toBiTape)).head = some v.enc[n]) ↔ + tv.current = v := by + -- Key: move_left/move_right cancellation + have bi_li : Function.LeftInverse (BiTape.move_left (Symbol := Char)) BiTape.move_right := + fun t => BiTape.move_right_move_left t + -- Position info + have h_pos := encodedPos_toRightEnd tv + have h_re : tv.toRightEnd.encodedPos = tv.encodedPos := by + congr 1; cases tv; simp_all [toRightEnd] + rw [h_re] at h_pos + -- h_pos : tv.encodedPos = tv.toLeftEnd.encodedPos + (tv.current.enc.length - 1) + have h_cenc := Data.enc_length_pos tv.current + have h_venc := Data.enc_length_pos v + -- Unfold toBiTape + have h_unfold : tv.toBiTape = + BiTape.move_right^[tv.encodedPos] (BiTape.mk₁ tv.data.enc) := by + simp [toBiTape] + rw [h_unfold] + -- Cancel helper: when m ≤ ep, iterate cancellation gives getElem? + have cancel_head (m ep : ℕ) (hle : m ≤ ep) (l : List Char) (n : ℕ) : + (BiTape.move_right^[n] (BiTape.move_left^[m] + (BiTape.move_right^[ep] (BiTape.mk₁ l)))).head = + l[ep - m + n]? := by + rw [show ep = m + (ep - m) from by omega, Function.iterate_add_apply, + bi_li.iterate m, ← Function.iterate_add_apply, + BiTape.head_iterate_move_right_mk₁] + congr 1; omega + -- move_left past tape start gives None + have move_left_past_start : ∀ (l : List Char) (j : ℕ), 0 < j → + (BiTape.move_left^[j] (BiTape.mk₁ l)).head = none := by + intro l j hj + suffices ∀ j, ∀ (t : BiTape Char), t.left = ∅ → 0 < j → + (BiTape.move_left^[j] t).head = none ∧ (BiTape.move_left^[j] t).left = ∅ from + (this j _ (by simp [BiTape.mk₁, StackTape.empty_eq_nil]) hj).1 + intro j + induction j with + | zero => intro t ht hj; omega + | succ j ih => + intro t ht hj + rw [Function.iterate_succ, Function.comp_apply] + have h1 : t.move_left.head = none := by + simp [BiTape.move_left, ht, StackTape.nil_head, StackTape.empty_eq_nil] + have h2 : t.move_left.left = ∅ := by + simp [BiTape.move_left, ht, StackTape.empty_eq_nil, StackTape.nil_tail] + cases j with + | zero => exact ⟨h1, h2⟩ + | succ j => exact ih t.move_left h2 (by omega) + constructor + · -- Forward: reads match v.enc → current = v + intro h_match + -- Step 1: v.enc.length - 1 ≤ tv.encodedPos + have h_le : v.enc.length - 1 ≤ tv.encodedPos := by + by_contra h_gt; push_neg at h_gt + have h0 := h_match 0 h_venc + simp only [Function.iterate_zero, Function.id_def] at h0 + rw [show v.enc.length - 1 = + (v.enc.length - 1 - tv.encodedPos) + tv.encodedPos from by omega, + Function.iterate_add_apply, bi_li.iterate tv.encodedPos] at h0 + rw [move_left_past_start _ _ (by omega)] at h0 + exact absurd h0 (by simp) + -- Step 2: Simplify h_match + have h_match' : ∀ n, (hn : n < v.enc.length) → + tv.data.enc[tv.encodedPos - (v.enc.length - 1) + n]? = some v.enc[n] := by + intro n hn + have := h_match n hn + rw [cancel_head _ _ h_le _ _] at this + exact this + -- Step 3: Build suffix relation + suffices h : tv.current.enc <:+ v.enc ∨ v.enc <:+ tv.current.enc by + rcases h with h | h + · exact Data.enc_suffix_free h + · exact (Data.enc_suffix_free h).symm + by_cases h_len : v.enc.length ≤ tv.current.enc.length + · -- v.enc <:+ current.enc + right + refine ⟨tv.current.enc.take (tv.current.enc.length - v.enc.length), + List.ext_getElem (by simp; omega) fun n h1 h2 => ?_⟩ + by_cases hn : n < tv.current.enc.length - v.enc.length + · rw [List.getElem_append_left (by simp; omega)] + exact (List.getElem_take' h2 hn).symm + · push_neg at hn + rw [List.getElem_append_right (by simp; omega)] + simp only [List.length_take_of_le (by omega : tv.current.enc.length - v.enc.length ≤ + tv.current.enc.length)] + have r1 := enc_current_slice tv.toLeftEnd rfl n h2 + have r2 := h_match' (n - (tv.current.enc.length - v.enc.length)) (by omega) + rw [show tv.encodedPos - (v.enc.length - 1) + + (n - (tv.current.enc.length - v.enc.length)) = + tv.toLeftEnd.encodedPos + n by omega] at r2 + rw [r1] at r2; exact (Option.some_injective _ r2).symm + · -- current.enc <:+ v.enc + push_neg at h_len + left + refine ⟨v.enc.take (v.enc.length - tv.current.enc.length), + List.ext_getElem (by simp; omega) fun n h1 h2 => ?_⟩ + by_cases hn : n < v.enc.length - tv.current.enc.length + · rw [List.getElem_append_left (by simp; omega)] + exact (List.getElem_take' h2 hn).symm + · push_neg at hn + rw [List.getElem_append_right (by simp; omega)] + simp only [List.length_take_of_le (by omega : v.enc.length - tv.current.enc.length ≤ + v.enc.length)] + have h_idx : n - (v.enc.length - tv.current.enc.length) < + tv.current.enc.length := by omega + have r1 := enc_current_slice tv.toLeftEnd rfl + (n - (v.enc.length - tv.current.enc.length)) h_idx + have r2 := h_match' n h2 + rw [show tv.encodedPos - (v.enc.length - 1) + n = + tv.toLeftEnd.encodedPos + + (n - (v.enc.length - tv.current.enc.length)) by omega] at r2 + rw [r1] at r2; exact Option.some_injective _ r2 + · -- Backward: current = v → reads match + intro h_eq; subst h_eq + intro n hn + rw [cancel_head _ _ (by omega) _ _, + show tv.encodedPos - (tv.current.enc.length - 1) = tv.toLeftEnd.encodedPos by omega] + exact enc_current_slice tv.toLeftEnd rfl n hn + +@[simp] +public lemma toBiTape_ofData (d : Data) : + (TapeView.ofData d).toBiTape = BiTape.mk₁ (Data.enc d) := by + simp [toBiTape] + +@[simp] +public lemma toBiTape_toRightEnd (tv : TapeView) : + tv.toRightEnd.toBiTape = BiTape.move_right^[tv.current.enc.length - 1] tv.toLeftEnd.toBiTape := by + simp only [toBiTape, toRightEnd, toLeftEnd, ← Function.iterate_add_apply] + congr 1 + have h := encodedPos_toRightEnd tv + simp only [toRightEnd, toLeftEnd] at h + omega + +/-- TODO document -/ +public def ofBiTape? (t : BiTape Char) : Option TapeView := sorry + +/-- TODO document -/ +@[expose] +public def ofBiTapes? {k : ℕ} + (tapes : Fin k → BiTape Char) : + Option (Fin k → TapeView) := + if h: ∀ i, (ofBiTape? (tapes i)).isSome then + some (fun i => (ofBiTape? (tapes i)).get (h i)) + else none + +@[simp] +public lemma toBiTape_ofBiTape (tv : TapeView) : + (ofBiTape? tv.toBiTape) = tv := by sorry + +@[simp] +public lemma toBiTape_comp_update {k : ℕ} {i : Fin k} + {views : Fin k → TapeView} {tv : TapeView} : + Function.update (toBiTape ∘ views) i tv.toBiTape = + toBiTape ∘ (Function.update views i tv) := by + ext j + by_cases h : i = j + · subst h; simp + · simp only [Function.comp_apply, Function.update_apply] + split <;> simp_all + +/-- Combined: moving right on tape `i` and updating equals updating with the target TapeView. -/ +public lemma toBiTape_comp_update_move_right {k : ℕ} {i : Fin k} + {views : Fin k → TapeView} {target : TapeView} + (h_data : (views i).data = target.data) + (h_enc : (views i).encodedPos + 1 = target.encodedPos) : + Function.update (toBiTape ∘ views) i (views i).toBiTape.move_right = + toBiTape ∘ Function.update views i target := by + rw [toBiTape_move_right_eq _ _ h_data h_enc, toBiTape_comp_update] + +@[simp] +public lemma ofBiTapes?_toBiTape {k : ℕ} + {views : Fin k → TapeView} : + TapeView.ofBiTapes? (TapeView.toBiTape ∘ views) = + some views := by + simp [ofBiTapes?] + +@[simp] +public lemma ofBiTape_get_toBiTape (tape : BiTape Char) + (h : (ofBiTape? tape).isSome) : + ((ofBiTape? tape).get h).toBiTape = tape := by sorry + +@[simp] +public lemma toBiTape_injective : + Function.Injective TapeView.toBiTape := by + sorry -- use the above + +@[simp] +public lemma toBitape_of_appendPath (tv : TapeView) (idx : ℕ) + (h : (tv.data.atPath (tv.path ++ [idx])).isSome) : + (TapeView.mk tv.data (tv.path ++ [idx]) HeadPos.leftEnd h).toBiTape = + BiTape.move_right^[1 + + ((tv.current.toList.take idx).map fun d : Data => d.enc.length).sum] + tv.toBiTape := by + unfold toBiTape + simp [←Function.iterate_add_apply, Data.toList, -List.map_take] + grind + +/-- Prepend a `Data` value to the front of a list on tape. + If the path is `[]` and `data` is `Data.list ds`, + returns `⟨Data.list (d :: ds), [], _⟩`. + Otherwise, returns the `TapeView` unchanged. -/ +@[expose] +public def pushList (d : Data) (tv : TapeView) : TapeView := + match tv with + | ⟨Data.list ds, [], headPos, _⟩ => ⟨Data.list (d :: ds), [], headPos, rfl⟩ + | other => other + +@[simp] +public lemma pushList_ofData {x d : Data} : + (TapeView.ofData d).pushList x = TapeView.ofEnc (x :: d.toList) := by + simp [pushList, ofData, ofEnc] + sorry + +@[simp] +public lemma pushList_list {d : Data} {ds : List Data} {headPos : HeadPos} : + (TapeView.mk (Data.list ds) [] headPos rfl).pushList d = + TapeView.mk (Data.list (d :: ds)) [] headPos rfl := by + unfold pushList; rfl + +@[simp] +public lemma pushList_nonempty_path {tv : TapeView} (h_nonempty : tv.path ≠ []) : + tv.pushList d = tv := by unfold pushList; split <;> grind + +/-- TODO document -/ +public def asWritableList (tv : TapeView) : Option (List Data) := + match tv with + | ⟨Data.list l, [], _, _⟩ => some l + | _ => none + +/-- Remove the first element from a list on tape. -/ +public def popList (tv : TapeView) : TapeView := + (tv.asWritableList.map fun ls => TapeView.ofList ls.tail).getD tv + +/-- If `tv` currently points at a non-empty list, returns its head, + otherwise returns none. -/ +public def currentListHead (tv : TapeView) : Option Data := + match tv.current with + | Data.list (d :: _) => some d + | _ => none + +/-- TODO document -/ +public def updateListHead (tv : TapeView) + (f : Data → Data) : TapeView := + match tv with + | ⟨Data.list (d :: ds), [], headPos, _⟩ => + ⟨Data.list (f d :: ds), [], headPos, rfl⟩ + | other => other + + +end TapeView + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/UniversalTM.lean b/Cslib/Computability/Machines/MultiTapeTuring/UniversalTM.lean new file mode 100644 index 0000000000..b4ba090840 --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/UniversalTM.lean @@ -0,0 +1,350 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.TapeView +public import Cslib.Computability.Machines.MultiTapeTuring.StructuralMachines +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Navigation +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Copy +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Eq +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Put +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.ListIteration +public import Cslib.Computability.Machines.MultiTapeTuring.Routines.Typed +import Mathlib.Order.Interval.Finset.Defs + +namespace Turing + +namespace UniversalTM + +open Routines + +variable [Inhabited Symbol] [Fintype Symbol] [StrEnc Symbol] + +/-- The cell of a single Turing tape. -/ +public structure TapeCell Symbol where + /-- The symbol in the cell. -/ + c : Option Symbol + /-- If the head is at this cell currently. -/ + containsHead : Bool + +public instance : StrEnc (TapeCell Symbol) where + toData cell := StrEnc.toData (cell.c, cell.containsHead) + +public instance (α : Type) [StrEnc α] (k : ℕ) : StrEnc (Vector α k) where + toData v := StrEnc.toData v.toList + +/- +Outline of UTM: +while the current state is not None: +- for each tape, find the head position on the multi-tape + and copy the current symbol to an aux tape. +- now the aux tape contains the symbols in the correct order. +- copy the current state to the aux tape. +- the contents of the aux tape is exactly the input to the + transition function +- "evaluate the transition function" by iterating through its + table and storing the result on another tape +- execute the actions for each of the tapes: + - find the head. update the symbol, update the head marking + according to the move action + (potentially extend the tape to the left or right) +- update the current state +-/ + +/- sub-routines we need: +- move to the first element of a list that satisfies a condition: + tm₁ tm₂ tm₃: For each item in the list: if tm₁ outputs true on an aux tape, run tm₂. + if it never outputs true, run tm₃ +- evaluate a function given by a list of input-output pairs +- update an element in a list, whose encoding size must be the same +- extend a list to the right +-/ + + +/-- Parameters for encoding a tuple of tapes as a single tape with multiple tracks. -/ +public structure EncodingParams (k : ℕ) where + /-- The encoding start for each tape, relative to the tape head. -/ + start : Fin k → ℤ + /-- The number of cells to encode. -/ + length : ℕ + +/-- The encoding of a tuple of tapes as a list of tuples of `TapeCell`s. +Note that the encoding can only be decoded for some values of `params`. -/ +public def encodeTapes {k : ℕ} (tapes : Fin k → BiTape Symbol) (params : EncodingParams k) : + List (Fin k → TapeCell Symbol) := + List.ofFn (n := params.length) fun p i => + { + c := (tapes i).get ((params.start i) + p) + containsHead := (params.start i) + p == 0 + } + +/-- The parameters are such that position `cellPos` of tape `tapeIdx` is part of the encoding. -/ +public def EncodingParams.encodesCell {k : ℕ} (params : EncodingParams k) + (tapeIdx : Fin k) (cellPos : ℤ) : Prop := + (params.start tapeIdx) ≤ cellPos ∧ cellPos - (params.start tapeIdx) < (params.length : ℤ) + +/-- The parameters are suitable to encode all relevant information of the tape. -/ +public def EncodingParams.encodesTape {k : ℕ} (params : EncodingParams k) (tapes : Fin k → BiTape Symbol) : Prop := + ∀ idx, + -- the head is encoded + params.encodesCell idx 0 ∧ + -- all non-none cells are encoded + ∀ i, (tapes idx).get i ≠ none → params.encodesCell idx i + + +/-- The encoding of tapes generated by `encodeTapes` plus a proof that we properly encoded the tape. -/ +public structure EncodedTapes (k : ℕ) where + /-- The tapes -/ + tapes : Fin k → BiTape Symbol + /-- The encoding params -/ + params : EncodingParams k + /-- The encoding is valid -/ + h_valid : params.encodesTape tapes + +instance (k : ℕ) : StrEnc (EncodedTapes k (Symbol := Symbol)) where + toData enc := StrEnc.toData (encodeTapes enc.tapes enc.params) + +omit [Inhabited Symbol] [Fintype Symbol] [StrEnc Symbol] in +/-- If a cell in the encoding is marked as containing the head, then its symbol is the +current head symbol of the corresponding tape. -/ +@[simp, grind =] +lemma encodeTapes_getElem_of_containsHead {k : ℕ} + {t : Fin k → BiTape Symbol} {params : EncodingParams k} + {idx : ℕ} (h_idx_lt : idx < (encodeTapes t params).length) {i : Fin k} + (h : (((encodeTapes t params)[idx]'h_idx_lt) i).containsHead) : + ((encodeTapes t params)[idx]'h_idx_lt) i = {c := (t i).head, containsHead := true} := by + simp_all [encodeTapes, BiTape.get] + +/-- The minimal head positions over all tapes at step `t` starting from initial zero positions. -/ +public def minHeadPos + {k : ℕ} (tm : MultiTapeTM k Symbol) (initialTapes : Fin k → BiTape Symbol) (t : ℕ) : ℤ := + (List.ofFn (tm.headPosition initialTapes t)).min?.getD 0 + +/-- The maximal head positions over all tapes at step `t` starting from initial zero positions. -/ +public def maxHeadPos + {k : ℕ} (tm : MultiTapeTM k Symbol) (initialTapes : Fin k → BiTape Symbol) (t : ℕ) : ℤ := + (List.ofFn (tm.headPosition initialTapes t)).max?.getD 0 + +-- TODO use this sequence of encoding parameters. + +/-- The execution sequence of tape encoding parameters. -/ +public def encodingParamSequence {k : ℕ} (tm : MultiTapeTM k Symbol) + (initialTapes : Fin k → BiTape Symbol) (t : ℕ) : EncodingParams k := + let headPositions := tm.headPosition initialTapes + -- The min head position over all tapes at a specific step + let minHeadPosAtStep := fun t' => (List.ofFn (headPositions t')).min?.getD 0 + let maxHeadPosAtStep := fun t' => (List.ofFn (headPositions t')).max?.getD 0 + -- The min head position over all tapes and all steps until step t + -- TODO check for off-by-one errors here + let minHeadPosUntil := (List.ofFn (n := t + 1) (fun t' => minHeadPosAtStep t')).min?.getD 0 + let maxHeadPosUntil := (List.ofFn (n := t + 1) (fun t' => maxHeadPosAtStep t')).max?.getD 0 + let length := 1 + (maxHeadPosUntil - minHeadPosUntil).toNat + let start := fun i => (headPositions t i) - minHeadPosUntil + ⟨ start, length ⟩ + +/-- The next tape encoding parameter set given the previous one. -/ +public def updateEncodingParams {k : ℕ} (tm : MultiTapeTM k Symbol) + (params : EncodingParams k) + (cfg : tm.Cfg) : EncodingParams k := sorry + -- match cfg with + -- | ⟨none, _⟩ => (fun _ => 0) + -- | ⟨some q, tapes⟩ => + -- match tm.tr q (fun i => (tapes i).head) with + -- | ⟨stmts, _⟩ => fun i => shifts i + (match (stmts i).movement with + -- | none => 0 + -- | .some .right => 1 + -- | .some .left => -1) + +-- TODO: Can we describe the semantics of getHeadSymbol on Data itself? +-- This way, we could maybe use Data-based lemmas only and thus +-- unconditional simp lemmas. One problem might be that the atPath +-- combinator does not work in all cases. +-- Solution: We define `ifHasElem idx tm\₁tm\2`. Using this, define `atPath` to only do +-- something if the path exists. +-- then find_list compares to `StrEnc.toData true` - if nothing was executed, +-- it is false. +-- So the discriminator in the list search is `d.atPath [tapeIdx, 1] == some (StrEnc.toData true)` +-- which is equivalent to `(tcs tapeIdx).containsHead` if `d = StrEnc.toData tcs` + +/-- Copies the symbol under the head of tape `tapeIdx` from the multi-track tape `tape` to +tape `out` using the auxiliary tape `aux`. -/ +def getHeadSymbol_v2 {k : ℕ} (tapeIdx : ℕ) (tapes out aux : Fin k) : MultiTapeTM k Char := + find_list tapes aux + -- Find the cell where the tapeIdx-th tape has the head + (atPath? [tapeIdx, 1] tapes (copyEnc tapes aux) noop) + -- copy the symbol to out and move back to the start of the list. + (atPath? [tapeIdx, 0] tapes (copy_to_list tapes out) noop ;ₜ outOfList tapes) + -- otherwise do nothing (because we know there is a head marker) + (noop) + +/-- Copies the symbol under the head of tape `tapeIdx` from the multi-track tape `tape` to +tape `out` using the auxiliary tape `aux`. -/ +def getHeadSymbol {k : ℕ} (tapeIdx : ℕ) (tapes out aux : Fin k) : MultiTapeTM k Char := + find_list tapes aux + -- Find the cell where the tapeIdx-th tape has the head + (atPath [tapeIdx, 1] tapes (copyEnc tapes aux)) + -- copy the symbol to out and move back to the start of the list. + (atPath [tapeIdx, 0] tapes (copy_to_list tapes out) ;ₜ outOfList tapes) + -- otherwise do nothing (because we know there is a head marker) + (noop) + + +omit [Fintype Symbol] [Inhabited Symbol] in +lemma getHeadSymbol.semantics {k k' : ℕ} (tapeIdx : Fin k') (tapes out aux : Fin k) + (h_distinct : [tapes, aux, out].get.Injective) + {views : Fin k → TapeView} + {encodedTapes : EncodedTapes k' (Symbol := Symbol)} + (h_tapes : views tapes = .ofEnc encodedTapes) + (h_aux : views aux = TapeView.empty) + (outl : List (Option Symbol)) + (h_outl : views out = .ofEnc outl) : + (getHeadSymbol tapeIdx tapes out aux).eval_struct views = .some (Function.update + views out (TapeView.ofEnc ((encodedTapes.tapes tapeIdx).head :: outl))) := by + have h_tapes_aux : tapes ≠ aux := + Function.Injective.ne h_distinct (show (0 : Fin 3) ≠ 1 by decide) + have h_tapes_out : tapes ≠ out := + Function.Injective.ne h_distinct (show (0 : Fin 3) ≠ 2 by decide) + have h_copyHeadPos : + computes_function_read_update' + (atPath [tapeIdx, 1] tapes (copyEnc tapes aux)) + (fun (tcs : Fin k' → TapeCell Symbol) _ => (tcs tapeIdx).containsHead) + tapes aux := + atPath_computes_function + (α := Fin k' → TapeCell Symbol) + (β := Bool) + (γ := Bool) + (tm := copyEnc tapes aux) + (path := [tapeIdx, 1]) + h_tapes_aux + (h_tm := copyEnc_computes_fun h_tapes_aux) + (h_path := by simp [StrEnc.toData]) + have h_copySymbol : + computes_function_read_push' + (atPath [tapeIdx, 0] tapes (copy_to_list tapes out)) + (fun (tcs : Fin k' → TapeCell Symbol) => (tcs tapeIdx).c) + tapes out := by + apply atPath_computes_function h_tapes_out + (h_tm := copy_to_list.computes_fun' h_tapes_out) + (h_path := by simp [StrEnc.toData]) + unfold getHeadSymbol + rw [find_list.computes_fun h_tapes_aux h_copyHeadPos views + (encodeTapes encodedTapes.tapes encodedTapes.params) + (by simp [h_tapes, StrEnc.toData]) h_aux] + obtain ⟨⟨headValid1, headValid2⟩, _⟩ := encodedTapes.h_valid tapeIdx + simp at headValid2 + -- Derive the head index and the `findIdx?` equation from the validity of `encodedTapes`. + let idx_z := -encodedTapes.params.start tapeIdx + let idx := idx_z.toNat + have h_idx_eq : (idx : ℤ) = idx_z := by simp_all [idx, idx_z] + have h_idx_lt : idx < (encodeTapes encodedTapes.tapes encodedTapes.params).length := by + simp_all [encodeTapes, idx, idx_z] + have h_pred : + (((encodeTapes encodedTapes.tapes encodedTapes.params)[idx]'h_idx_lt) tapeIdx).containsHead = + true := by + simp [encodeTapes, h_idx_eq, idx_z] + have h_contains_head : (encodeTapes encodedTapes.tapes encodedTapes.params).findIdx? + (fun c => (c tapeIdx).containsHead) = some idx := by + rw [List.findIdx?_eq_some_iff_getElem] + grind [encodeTapes] + simp only [h_contains_head, TapeView.appendPath', seq_eval_struct] + rw [h_copySymbol (encodeTapes encodedTapes.tapes encodedTapes.params)[idx] + outl _ + (by simp [h_tapes, StrEnc.toData, h_idx_lt]) + (by simp [Function.update, h_outl, h_tapes_out.symm])] + simp + grind + +/-- Copies symbols under the heads of all tapes for `tapeCount` tapes from the multi-track +tape `tapes` to tape `out` using the auxiliary tape `aux`. -/ +def getHeadSymbols {k : ℕ} (tapeCount : ℕ) (tapes out aux : Fin k) : MultiTapeTM k Char := + match tapeCount with + | 0 => noop + | tapeCount + 1 => + getHeadSymbol tapeCount tapes out aux ;ₜ getHeadSymbols tapeCount tapes out aux + +omit [Fintype Symbol] [Inhabited Symbol] in +lemma getHeadSymbols.semantics {k k' : ℕ} (tapes out aux : Fin k) + (h_distinct : [tapes, aux, out].get.Injective) + {views : Fin k → TapeView} + {encodedTapes : EncodedTapes k' (Symbol := Symbol)} + (h_tapes : views tapes = .ofEnc encodedTapes) + (h_aux : views aux = TapeView.empty) + (outl : List (Option Symbol)) + (h_outl : views out = .ofEnc outl) : + (getHeadSymbols k' tapes out aux).eval_struct views = .some (Function.update + views out (TapeView.ofEnc + ((List.ofFn (fun i : Fin k' => (encodedTapes.tapes i).head)) ++ outl))) := by + have h_tapes_out : tapes ≠ out := + Function.Injective.ne h_distinct (show (0 : Fin 3) ≠ 2 by decide) + have h_aux_out : aux ≠ out := + Function.Injective.ne h_distinct (show (1 : Fin 3) ≠ 2 by decide) + suffices h : ∀ (tc : ℕ) (h_le : tc ≤ k') {views : Fin k → TapeView} + (outl : List (Option Symbol)), + views tapes = .ofEnc encodedTapes → views aux = TapeView.empty → + views out = .ofEnc outl → + (getHeadSymbols tc tapes out aux).eval_struct views = .some (Function.update + views out (TapeView.ofEnc ((List.ofFn (fun i : Fin tc => + (encodedTapes.tapes (Fin.castLE h_le i)).head)) ++ outl))) by + simpa using h k' (le_refl _) outl h_tapes h_aux h_outl + intro tc h_le views outl h_tapes h_aux h_outl + induction tc generalizing views outl with + | zero => simp [getHeadSymbols, h_outl] + | succ tc ih => + unfold getHeadSymbols + rw [seq_eval_struct, + getHeadSymbol.semantics ⟨tc, h_le⟩ tapes out aux h_distinct h_tapes h_aux outl h_outl] + simp only [Part.bind_some] + rw [ih (by omega) ((encodedTapes.tapes ⟨tc, h_le⟩).head :: outl) + (by grind) (by grind) (by simp)] + congr 1 + rw [Function.update_idem, List.ofFn_succ' (n := tc) + (f := fun i : Fin (tc+1) => (encodedTapes.tapes (Fin.castLE h_le i)).head)] + simp [Fin.castLE] + +def provideTransitionInput {k : ℕ} (tapeCount : ℕ) + (state tapes out aux : Fin k) : MultiTapeTM k Char := + replace Data.empty out ;ₜ getHeadSymbols tapeCount tapes out aux ;ₜ copy_to_list state out + +-- states, tapes, out, aux: 1 2 3 4 +omit [Fintype Symbol] [Inhabited Symbol] in +lemma provideTransitionInput.semantics {k' : ℕ} + {views : Fin 5 → TapeView} + {encodedTapes : EncodedTapes k' (Symbol := Symbol)} + (h_tapes : views 2 = .ofEnc encodedTapes) + (h_aux : views 4 = TapeView.empty) : + (provideTransitionInput k' 1 2 3 4).eval_struct views = .some (Function.update + views 3 (TapeView.ofEnc ((views 1).current :: + List.ofFn fun i : Fin k' => StrEnc.toData (encodedTapes.tapes i).head))) := by + simp only [provideTransitionInput, seq_eval_struct, replace.eval_struct, + Part.coe_some, Part.bind_some] + rw [getHeadSymbols.semantics (encodedTapes := encodedTapes) (Symbol := Symbol) 2 3 4 (by decide) + (by simp [h_tapes]) (by simp [h_aux]) [] (by simp [StrEnc.toData])] + simp + congr + +/-- Execute a single step of the simulated machine. -/ +public def utm_step : MultiTapeTM 10 Char := sorry + +/-- Main theorem -/ +public theorem utm_step_semantics + {k : ℕ} (tm : MultiTapeTM k Symbol) + [StrEnc tm.State] -- it is a fintype, so easy to satsify + (cfg : tm.Cfg) + (views : Fin 10 → TapeView) + (params : EncodingParams k) + (h_tapes : views 1 = .ofEnc (encodeTapes cfg.tapes params)) + (h_state : views 2 = .ofEnc cfg.state) : + utm_step.eval_struct views = .some (match tm.step cfg with + | none => views + | some cfg' => Function.update (Function.update views + 1 (.ofEnc (encodeTapes cfg'.tapes (updateEncodingParams tm params cfg)))) + 2 (.ofEnc cfg'.state)) := by sorry + +end UniversalTM + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/WhileCombinator.lean b/Cslib/Computability/Machines/MultiTapeTuring/WhileCombinator.lean new file mode 100644 index 0000000000..97d46133ce --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/WhileCombinator.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +import Cslib.Foundations.Data.BiTape +import Cslib.Foundations.Data.RelatesInSteps + +public import Cslib.Computability.Machines.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.ListEncoding +public import Cslib.Computability.Machines.MultiTapeTuring.HeadStats + +namespace Turing + +namespace Routines + +variable [Inhabited α] [Fintype α] +variable {k : ℕ} + +/-- +Repeatedly run a sub routine as long as a condition on the symbol +at the head of tape `i` is true. +-/ +public def doWhileSymbol (cond : Option α → Bool) (i : Fin k) (tm : MultiTapeTM k α) : + MultiTapeTM k α where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp] +public theorem doWhileSymbol_eval + (cond : Option α → Bool) + (i : Fin k) + (tm : MultiTapeTM k α) + (tapes_seq : ℕ → Fin k → BiTape α) + (h_transform : ∀ j, tm.eval (tapes_seq j) = .some (tapes_seq j.succ)) + (h_stops : ∃ m, cond (tapes_seq m i).head = false) : + (doWhileSymbol cond i tm).eval (tapes_seq 0) = .some (tapes_seq (Nat.find h_stops)) := by + sorry + +/-- Repeatedly run a sub routine as long as the first word on tape `i` is non-empty. +-/ +public def doWhile (i : Fin k) (tm : MultiTapeTM k (WithSep α)) : + MultiTapeTM k (WithSep α) where + State := PUnit + stateFintype := inferInstance + q₀ := PUnit.unit + tr _ syms := sorry + +@[simp] +public theorem doWhile_eval_list + {i : Fin k} + {tm : MultiTapeTM k (WithSep α)} + {tapes : Fin k → List (List α)} + (h_halts : ∀ tapes, tm.HaltsOnLists tapes) : + (doWhile i tm).eval_list tapes = + ⟨∃ n, ((tm.eval_list_tot h_halts)^[n] tapes i).head?.getD [] = [], + fun h_loopEnds => (tm.eval_list_tot h_halts)^[Nat.find h_loopEnds] tapes⟩ := by + sorry + +end Routines + +end Turing diff --git a/Cslib/Computability/Machines/MultiTapeTuring/WithTapes.lean b/Cslib/Computability/Machines/MultiTapeTuring/WithTapes.lean new file mode 100644 index 0000000000..209179db9f --- /dev/null +++ b/Cslib/Computability/Machines/MultiTapeTuring/WithTapes.lean @@ -0,0 +1,127 @@ +/- +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.MultiTapeTuring.Basic +public import Cslib.Computability.Machines.MultiTapeTuring.TapeExtension + +public import Mathlib.Logic.Equiv.Fintype +public import Mathlib.Data.Finset.Sort + +namespace Turing + +variable [Inhabited α] [Fintype α] + +variable {k : ℕ} + +/-- +Permute tapes according to a bijection. +-/ +public def MultiTapeTM.permute_tapes + (tm : MultiTapeTM k α) (σ : Equiv.Perm (Fin k)) : MultiTapeTM k α where + State := tm.State + stateFintype := tm.stateFintype + q₀ := tm.q₀ + tr := fun q syms => match tm.tr q (syms ∘ σ) with + | (stmts, q') => (stmts ∘ σ.symm, q') + +--- General theorem: permuting tapes commutes with evaluation +@[simp, grind =] +public theorem MultiTapeTM.permute_tapes_eval + (tm : MultiTapeTM k α) (σ : Equiv.Perm (Fin k)) (tapes : Fin k → BiTape α) : + (tm.permute_tapes σ).eval tapes = + (tm.eval (tapes ∘ σ)).map (fun tapes' => tapes' ∘ σ.symm) := by + sorry + +private def findFin {k : ℕ} (p : Fin k → Prop) [DecidablePred p] (h : ∃ i, p i) : Fin k := + (Finset.univ.filter p).min' (by + simp only [Finset.Nonempty, Finset.mem_filter, Finset.mem_univ, true_and] + exact h) + +def inj_to_perm {k₁ k₂ : ℕ} (f : Fin k₁ → Fin k₂) (h_inj : f.Injective) : + Equiv.Perm (Fin k₂) + -- non-computable version + -- let f' : {i : Fin k₂ // i < k₁} → Fin k₂ := fun ⟨i, _⟩ => f ⟨i, by omega⟩ + -- have h_f'_inj : f'.Injective := by intro a b h; grind + -- (Equiv.ofInjective f' h_f'_inj).extendSubtype + where + toFun := sorry + invFun := sorry + left_inv := by sorry + right_inv := by sorry + +/-- +Change the order of the tapes of a Turing machine. +Example: For a 2-tape Turing machine tm, +`tm.with_tapes [2, 4].get (by grind)` is a 5-tape Turing machine whose tape 2 is +the original machine's tape 0 and whose tape 4 is the original +machine's tape 1 +Note that `f` is a function to `Fin k₂`, which means that integer literals +automatically wrap. You have to be careful to make sure that the target machine +has the right amount of tapes. +-/ +public def MultiTapeTM.with_tapes {k₁ k₂ : ℕ} +-- TODO use embedding instead? + (tm : MultiTapeTM k₁ α) (f : Fin k₁ → Fin k₂) (h_inj : f.Injective) : MultiTapeTM k₂ α := + (tm.extend + (by simpa using Fintype.card_le_of_injective f h_inj)).permute_tapes (inj_to_perm f h_inj) + +-- TODO do not use `h.choose` here but rather assume that `f` is injective. + +/-- +Updates `tapes` by choosing elements from `tapes'` according to (the partial inverse of) `f`. +-/ +public noncomputable def apply_updates + {γ : Type} + {k₁ k₂ : ℕ} + (tapes : Fin k₂ → γ) + (tapes' : Fin k₁ → γ) + (f : Fin k₁ → Fin k₂) + (i : Fin k₂) : γ := + if h : ∃ j, f j = i then tapes' h.choose else tapes i + +@[simp, grind =] +public lemma apply_updates_function_update_apply + {γ : Type} + {k₁ k₂ : ℕ} + {tapes : Fin k₂ → γ} + {f : Fin k₁ → Fin k₂} + (h_inj : f.Injective) + {t : Fin k₁} + {new_val : γ} + {i : Fin k₂} : + apply_updates tapes (Function.update (tapes ∘ f) t new_val) f i = + Function.update tapes (f t) new_val i := by + sorry + +@[simp, grind =] +public lemma apply_updates_function_update + {γ : Type} + {k₁ k₂ : ℕ} + {tapes : Fin k₂ → γ} + {f : Fin k₁ → Fin k₂} + (h_inj : f.Injective) + {t : Fin k₁} + {new_val : γ} : + apply_updates tapes (Function.update (tapes ∘ f) t new_val) f = + Function.update tapes (f t) new_val := by + funext i + apply apply_updates_function_update_apply h_inj + +@[simp, grind =] +public theorem MultiTapeTM.with_tapes_eval + {k₁ k₂ : ℕ} + {tm : MultiTapeTM k₁ α} {f : Fin k₁ → Fin k₂} {h_inj : f.Injective} + {tapes : Fin k₂ → BiTape α} : + (tm.with_tapes f h_inj).eval tapes = + (tm.eval (tapes ∘ f)).map + (fun tapes' => fun t => apply_updates tapes tapes' f t) := by + simp [with_tapes] + sorry + + +end Turing diff --git a/Cslib/Foundations/Data/BiTape.lean b/Cslib/Foundations/Data/BiTape.lean index ba71605564..3274d2fcaa 100644 --- a/Cslib/Foundations/Data/BiTape.lean +++ b/Cslib/Foundations/Data/BiTape.lean @@ -74,9 +74,36 @@ and laying them out to the right side, with the head under the first element of the list if it exists. -/ def mk₁ (l : List Symbol) : BiTape Symbol := - match l with - | [] => ∅ - | h :: t => { head := some h, left := ∅, right := StackTape.map_some t } + { head := l.head?, left := ∅, right := StackTape.map_some l.tail } + +/-- Construct a BiTape from the left (reversed) and right part. -/ +def mk₂ (l r : List Symbol) : BiTape Symbol := + ⟨r.head?, StackTape.map_some l, StackTape.map_some r.tail ⟩ + +/-- Returns the tape symbol at positon `p` relative to the head, where +positive numbers are right of the head and negative are left of the head. -/ +def get (t : BiTape Symbol) : ℤ → Option Symbol + | Int.ofNat 0 => t.head + | Int.ofNat (Nat.succ p') => t.right.toList[p']?.getD none + | Int.negSucc p' => t.left.toList[p']?.getD none + +/-- Two tapes are equal if and only if their `get` functions are equal. This allows to view +tapes as functions `ℤ → Option Symbol`. -/ +lemma ext_get' (t₁ t₂ : BiTape Symbol) (h_get_eq : ∀ p, t₁.get p = t₂.get p) : + t₁ = t₂ := by + obtain ⟨head₁, left₁, right₁⟩ := t₁ + obtain ⟨head₂, left₂, right₂⟩ := t₂ + have h_head : head₁ = head₂ := by simpa [get] using h_get_eq 0 + have h_right : right₁ = right₂ := by + apply StackTape.ext_get + intro p + simpa [get] using h_get_eq p.succ + have h_left : left₁ = left₂ := by + apply StackTape.ext_get + intro p + simpa [get] using h_get_eq (Int.negSucc p) + simp only [h_head, h_left, h_right] + section Move @@ -114,6 +141,94 @@ lemma move_left_move_right (t : BiTape Symbol) : t.move_left.move_right = t := b lemma move_right_move_left (t : BiTape Symbol) : t.move_right.move_left = t := by simp [move_left, move_right] +@[simp] +lemma move_left_move_right_iterate (t : BiTape Symbol) (n : ℕ) : + (move_left^[n] (move_right^[n] t)) = t := by + exact Function.LeftInverse.iterate BiTape.move_right_move_left _ _ + +@[simp] +lemma move_right_move_left_iterate (t : BiTape Symbol) (n : ℕ) : + (move_right^[n] (move_left^[n] t)) = t := by + exact Function.LeftInverse.iterate BiTape.move_left_move_right _ _ + +-- TODO clean up (ai) +@[simp] +lemma head_iterate_move_right_mk₁ (l : List Symbol) (n : ℕ) : + (move_right^[n] (mk₁ l)).head = l[n]? := by + suffices ∀ (t : BiTape Symbol) (r : List Symbol), + t.head = r.head? → t.right = StackTape.map_some r.tail → + ∀ m, (move_right^[m] t).head = r[m]? from + this (mk₁ l) l (by simp [mk₁, List.head?_eq_getElem?]) + (by simp [mk₁]) n + intro t r h_head h_right m + induction m generalizing t r with + | zero => simpa [List.head?_eq_getElem?] using h_head + | succ m ih => + simp only [Function.iterate_succ, Function.comp_apply, move_right] + cases r with + | nil => simp [h_right, ih _ []] + | cons h' t' => apply ih <;> simp [h_right] + +/-- Translate an optional direction into a head movement offset, where the positive +direction is to the right. -/ +def optionDirToInt (d : Option Dir) : ℤ := + match d with + | none => 0 + | some .left => -1 + | some .right => 1 + +@[simp] +lemma move_left_get (t : BiTape Symbol) (p : ℤ) : + (t.move_left).get p = t.get (p - 1) := by + unfold move_left get + match p with + | Int.ofNat 0 => + rw [show Int.ofNat 0 - 1 = Int.negSucc 0 from rfl] + simp [StackTape.head_eq_getD] + | Int.ofNat 1 => simp + | Int.ofNat (n + 2) => + rw [show Int.ofNat (n + 2) - 1 = Int.ofNat (n + 1) from by grind] + simp + | Int.negSucc n => simp + +@[simp] +lemma move_right_get (t : BiTape Symbol) (p : ℤ) : + (t.move_right).get p = t.get (p + 1) := by + unfold move_right get + match p with + | Int.ofNat n => + rw [show Int.ofNat n + 1 = Int.ofNat (n + 1) from by grind] + cases n <;> simp [StackTape.head_eq_getD] + | Int.negSucc 0 => simp + | Int.negSucc (n + 1) => + rw [show Int.negSucc (n + 1) + 1 = Int.negSucc n from rfl] + simp + +@[simp] +lemma optionMove_get (t : BiTape Symbol) (d : Option Dir) (p : ℤ) : + (t.optionMove d).get p = t.get (p + optionDirToInt d) := by + unfold optionMove optionDirToInt + cases d with + | none => simp + | some d => + cases d <;> simp [move, show p + (-1 : ℤ) = p - 1 from by omega] + +@[simp] +lemma move_right_iterate_get (t : BiTape Symbol) (n : ℕ) (p : ℤ) : + (move_right^[n] t).get p = t.get (p + n):= by + induction n generalizing t p with + | zero => simp + | succ n ih => simp [Function.iterate_succ_apply, ih, Int.add_assoc] + +@[simp] +lemma move_left_iterate_get (t : BiTape Symbol) (n : ℕ) (p : ℤ) : + (move_left^[n] t).get p = t.get (p - n):= by + induction n generalizing t p with + | zero => simp + | succ n ih => + have : p - n - 1 = p - (n + 1) := by grind + simp [Function.iterate_succ_apply, ih, this] + end Move /-- @@ -121,6 +236,16 @@ Write a value under the head of the `BiTape`. -/ def write (t : BiTape Symbol) (a : Option Symbol) : BiTape Symbol := { t with head := a } +@[simp] +lemma write_get (t : BiTape Symbol) (a : Option Symbol) : + (t.write a).get = Function.update t.get 0 a := by + unfold write get Function.update + funext p + match p with + | Int.ofNat 0 => simp + | Int.ofNat (n + 1) => simp; grind + | Int.negSucc n => simp + /-- The space used by a `BiTape` is the number of symbols between and including the head, and leftmost and rightmost non-blank symbols on the `BiTape`. @@ -135,7 +260,7 @@ lemma space_used_write (t : BiTape Symbol) (a : Option Symbol) : lemma space_used_mk₁ (l : List Symbol) : (mk₁ l).space_used = max 1 l.length := by cases l with - | nil => simp [mk₁, space_used, nil, StackTape.length_nil] + | nil => simp [mk₁, space_used, StackTape.length_nil] | cons h t => simp [mk₁, space_used, StackTape.length_nil, StackTape.length_map_some]; omega lemma space_used_move (t : BiTape Symbol) (d : Dir) : diff --git a/Cslib/Foundations/Data/StackTape.lean b/Cslib/Foundations/Data/StackTape.lean index f495d897a2..4bff37a325 100644 --- a/Cslib/Foundations/Data/StackTape.lean +++ b/Cslib/Foundations/Data/StackTape.lean @@ -86,7 +86,7 @@ def cons (x : Option Symbol) (xs : StackTape Symbol) : StackTape Symbol := | some a, ⟨l, hl⟩ => ⟨some a :: l, by grind⟩ @[simp, scoped grind =] -lemma cons_none_nil_toList : (cons none (nil : StackTape Symbol)).toList = [] := by grind +lemma cons_none_nil : cons none (nil : StackTape Symbol) = nil := by grind @[simp, scoped grind =] lemma cons_some_toList (a : Symbol) (l : StackTape Symbol) : @@ -106,6 +106,25 @@ def head (l : StackTape Symbol) : Option Symbol := | [] => none | h :: _ => h +lemma head_eq_getD (s : StackTape Symbol) : + s.head = s.toList[0]?.getD none := by + unfold head; cases s.toList <;> simp + +@[simp] +lemma tail_getD (s : StackTape Symbol) (n : ℕ) : + s.tail.toList[n]?.getD none = s.toList[n + 1]?.getD none := by + cases s with | mk l h => cases l <;> simp [tail, nil] + +@[simp] +lemma cons_getD_zero (x : Option Symbol) (s : StackTape Symbol) : + (cons x s).toList[0]?.getD none = x := by + cases x <;> (cases s with | mk l h => cases l <;> simp [cons]) + +@[simp] +lemma cons_getD_succ (x : Option Symbol) (s : StackTape Symbol) (n : ℕ) : + (cons x s).toList[n + 1]?.getD none = s.toList[n]?.getD none := by + cases x <;> (cases s with | mk l h => cases l <;> simp [cons]) + lemma eq_iff (l1 l2 : StackTape Symbol) : l1 = l2 ↔ l1.head = l2.head ∧ l1.tail = l2.tail := by constructor @@ -115,6 +134,29 @@ lemma eq_iff (l1 l2 : StackTape Symbol) : cases l2 with | mk as2 h2 => cases as1 <;> cases as2 <;> grind +lemma ext (t₁ t₂ : StackTape Symbol) (h_toList_eq : t₁.toList = t₂.toList) : + t₁ = t₂ := by + obtain ⟨t₁, h₁⟩ := t₁ + obtain ⟨t₂, h₂⟩ := t₂ + simpa using h_toList_eq + +lemma ext_get (t₁ t₂ : StackTape Symbol) + (h_get_eq : ∀ p, t₁.toList.getD p none = t₂.toList.getD p none) : + t₁ = t₂ := by + apply ext + obtain ⟨l₁, h₁⟩ := t₁ + obtain ⟨l₂, h₂⟩ := t₂ + simp only [List.getD_eq_getElem?_getD] at h_get_eq + have hlen : l₁.length = l₂.length := by grind + apply List.ext_getElem hlen + grind + +@[simp] +lemma nil_head : (nil : StackTape Symbol).head = none := by simp [head, nil_toList] + +@[simp] +lemma nil_tail : (nil : StackTape Symbol).tail = nil := by simp [tail] + @[simp] lemma head_cons (o : Option Symbol) (l : StackTape Symbol) : (cons o l).head = o := by cases o with @@ -142,6 +184,21 @@ lemma cons_head_tail (l : StackTape Symbol) : @[scoped grind] def map_some (l : List Symbol) : StackTape Symbol := ⟨l.map some, by simp⟩ +@[simp] +lemma map_some_toList (l : List Symbol) : (map_some l).toList = l.map some := rfl + +@[simp] +lemma map_some_head (l : List Symbol) : (map_some l).head = l.head? >>= some := by + cases l with + | nil => simp [map_some, head] + | cons h t => simp [map_some, head] + +@[simp] +lemma map_some_tail (l : List Symbol) : (map_some l).tail = map_some l.tail := by + cases l with + | nil => simp [map_some, tail, nil] + | cons h t => simp [map_some, tail] + section Length /-- The length of the `StackTape` is the number of elements up to the last non-`none` element -/ diff --git a/Encoding.lean b/Encoding.lean new file mode 100644 index 0000000000..81e772e0a9 --- /dev/null +++ b/Encoding.lean @@ -0,0 +1,400 @@ +import Lean.Elab.Deriving.Basic +import Lean.Elab.Deriving.Util +import Mathlib.Data.List.Basic + +/-! +# String Encoding of Algebraic Types + +We define an encoding of non-recursive algebraic types and lists of such types +into strings over the alphabet `{(, ), 1, 2}`. + +## Dyadic (bijective base-2) encoding of natural numbers + +The dyadic encoding uses digits `1` and `2` (no zero digit): + +- `dyadicEnc 0 = ""` +- `dyadicEnc (2k+1) = dyadicEnc k ++ "1"` +- `dyadicEnc (2k+2) = dyadicEnc k ++ "2"` + +The full encoding of a natural number wraps the dyadic digits in parentheses: +`encNat n = "(" ++ dyadicEnc n ++ ")"`. + +## Encoding of non-recursive inductive types + +For a type with constructors `c₀, c₁, …, cₘ₋₁` (0-indexed), we define: +``` +enc (cᵢ a₁ … aₙ) = "(" ++ encNat i ++ enc a₁ ++ … ++ enc aₙ ++ ")" +``` + +## Encoding of lists + +``` +enc l = "(" ++ enc x₁ ++ … ++ enc xₙ ++ ")" +``` + +## Key property + +Every encoded value is enclosed in `()`, and every encodable type has a finite +nesting depth of parentheses. This means an encoded value can be skipped using +finite control only (no separate counter needed). + +## Automatic derivation + +For any non-recursive inductive type, `deriving StrEnc` automatically generates +the encoding instance following the rules above. +-/ + +/-! ### Dyadic encoding -/ + +/-- Dyadic (bijective base-2) encoding of a natural number as a string over `{1, 2}`. + + - `0 ↦ ""` + - `2k + 1 ↦ dyadicEnc k ++ "1"` + - `2k + 2 ↦ dyadicEnc k ++ "2"` -/ +def dyadicEnc (n : ℕ) : String := + match n with + | 0 => "" + | n + 1 => + let m := n + 1 + if m % 2 = 1 then + dyadicEnc (m / 2) ++ "1" + else + dyadicEnc (m / 2 - 1) ++ "2" +termination_by n +decreasing_by + · omega + · omega + +/-- Encoding of a natural number: its dyadic representation enclosed in parentheses. -/ +def encNat (n : ℕ) : String := "(" ++ dyadicEnc n ++ ")" + +/-! #### Sanity checks for dyadic encoding -/ + +section DyadicExamples + +#eval dyadicEnc 0 -- "" +#eval dyadicEnc 1 -- "1" +#eval dyadicEnc 2 -- "2" +#eval dyadicEnc 3 -- "11" +#eval dyadicEnc 4 -- "12" +#eval dyadicEnc 5 -- "21" +#eval dyadicEnc 6 -- "22" + +#eval encNat 0 -- "()" +#eval encNat 1 -- "(1)" +#eval encNat 2 -- "(2)" +#eval encNat 3 -- "(11)" + +end DyadicExamples + +/-! ### Typeclass for string-encodable types -/ + +/-- Typeclass for types whose values can be encoded as strings over `{(, ), 1, 2}`. + `depth` is the maximum parenthesis nesting depth of any encoded value. + `fieldDepths[i][j]` is the depth of the `j`-th field of the `i`-th constructor + (for types using the constructor-index encoding scheme). + Set to `#[]` for `ℕ` and `List α`, which use their own encoding schemes. -/ +class StrEnc (α : Type*) where + enc : α → String + depth : ℕ + /-- For inductive types: `fieldDepths[i][j] = StrEnc.depth` of the `j`-th field + of the `i`-th constructor. Empty for `ℕ` and `List`. -/ + fieldDepths : Array (Array ℕ) + +/-- Natural numbers are encoded via `encNat`. -/ +instance : StrEnc ℕ where + enc := encNat + depth := 1 + fieldDepths := #[] + +/-- Lists are encoded by concatenating the encodings of elements, wrapped in parens. -/ +instance instStrEncList [StrEnc α] : StrEnc (List α) where + enc l := "(" ++ String.join (l.map StrEnc.enc) ++ ")" + depth := StrEnc.depth (α := α) + 1 + fieldDepths := #[] + +/-! ### Automatic `deriving StrEnc` for non-recursive inductive types + +The handler generates, for each constructor `cᵢ` (0-indexed) with fields `f₀ … fₙ`: +``` +enc (cᵢ f₀ … fₙ) = "(" ++ encNat i ++ StrEnc.enc f₀ ++ … ++ StrEnc.enc fₙ ++ ")" +``` +`StrEnc` instances for the field types are resolved via typeclass inference. +-/ + +section StrEncDeriving + +open Lean Elab Meta Parser Term Elab.Deriving Elab.Command + +/-- Build the match body for the `enc` function of `indVal`. + For each constructor `cᵢ` (identified by `ctorInfo.cidx`) with fields `f₀ … fₙ`: + `| cᵢ f₀ … fₙ => "(" ++ encNat i ++ StrEnc.enc f₀ ++ … ++ ")"` -/ +private def mkStrEncMatch (header : Header) (indVal : InductiveVal) : TermElabM Term := do + let discrs ← mkDiscrs header indVal + let mut alts : Array (TSyntax ``matchAlt) := #[] + for ctorName in indVal.ctors do + let ctorInfo ← getConstInfoCtor ctorName + -- Use simple names x0, x1, … for fields (no fresh-name generation which adds ✝). + let fieldNames : Array Name := Array.range ctorInfo.numFields |>.map fun i => + Name.mkSimple s!"x{i}" + let fieldIdents : Array (TSyntax `ident) := fieldNames.map mkIdent + -- Pattern + RHS: use ident* splice so pattern is flat (avoids nested-app rejection) + let idxLit : Term := Syntax.mkNumLit (toString ctorInfo.cidx) + let mut rhs : Term ← `("(" ++ encNat $idxLit) + for fv in fieldIdents do + rhs ← `($rhs ++ StrEnc.enc $fv) + rhs ← `($rhs ++ ")") + alts := alts.push (← `(matchAltExpr| | $(mkIdent ctorName) $fieldIdents:ident* => $rhs)) + `(match $[$discrs],* with $alts:matchAlt*) + +/-- Convert a field type `Expr` to a `Term`, substituting type-parameter free variables + with the names actually used in the instance binder (`paramFVars[i] → paramNames[i]`). + Runs in `MetaM` so it can be used directly inside `forallBoundedTelescope` callbacks. -/ +private partial def exprToFieldTypeTerm + (paramFVars : Array Expr) (paramNames : Array Name) : Expr → MetaM Term + | .fvar fvarId => do + match paramFVars.findIdx? (fun fv => fv.fvarId! == fvarId) with + | some i => return mkIdent paramNames[i]! + | none => throwError "StrEnc depth: unexpected free variable in field type" + | .const name _ => return mkIdent name -- strip universe levels (List, Nat, Literal, …) + | .app f arg => do + let fTerm ← exprToFieldTypeTerm paramFVars paramNames f + let argTerm ← exprToFieldTypeTerm paramFVars paramNames arg + `($fTerm $argTerm) + | other => + throwError "StrEnc depth: unsupported field type expression {other}" + +/-- Build the depth term for one constructor. + Returns `MetaM Term` so it can be called inside `forallBoundedTelescope`. -/ +private def mkCtorDepthTerm + (ctorInfo : ConstructorVal) (typeParamNames : Array Name) : MetaM Term := + Meta.forallBoundedTelescope ctorInfo.type + (some (ctorInfo.numParams + ctorInfo.numFields)) fun fvars _ => do + let paramFVars := fvars.extract 0 ctorInfo.numParams + let fieldFVars := fvars.extract ctorInfo.numParams (ctorInfo.numParams + ctorInfo.numFields) + let mut acc : Term := Syntax.mkNumLit "1" + for fv in fieldFVars do + let fieldTy ← Meta.inferType fv + let fieldTyTerm ← exprToFieldTypeTerm paramFVars typeParamNames fieldTy + acc ← `(Nat.max $acc (StrEnc.depth (α := $fieldTyTerm))) + `(1 + $acc) + +/-- Build a `Term` computing `depth` for the whole inductive type. + `typeParamNames` must match the binder names in the generated instance. -/ +private def mkTypeDepthTerm + (indVal : InductiveVal) (typeParamNames : Array Name) : TermElabM Term := do + let depths ← indVal.ctors.mapM fun ctorName => do + let ctorInfo ← getConstInfoCtor ctorName + liftMetaM (mkCtorDepthTerm ctorInfo typeParamNames) + match depths with + | [] => return Syntax.mkNumLit "0" + | d :: ds => ds.foldlM (fun acc t => `(Nat.max $acc $t)) d + +/-- For one constructor, build an `Array ℕ` term listing the `StrEnc.depth` of each field. -/ +private def mkCtorFieldDepthsTerm + (ctorInfo : ConstructorVal) (typeParamNames : Array Name) : MetaM Term := + Meta.forallBoundedTelescope ctorInfo.type + (some (ctorInfo.numParams + ctorInfo.numFields)) fun fvars _ => do + let paramFVars := fvars.extract 0 ctorInfo.numParams + let fieldFVars := fvars.extract ctorInfo.numParams (ctorInfo.numParams + ctorInfo.numFields) + let fieldTerms : Array Term ← fieldFVars.mapM fun fv => do + let fieldTy ← Meta.inferType fv + let fieldTyTerm ← exprToFieldTypeTerm paramFVars typeParamNames fieldTy + `(StrEnc.depth (α := $fieldTyTerm)) + `(#[$fieldTerms,*]) + +/-- Build the `Array (Array ℕ)` term for `fieldDepths` of the whole inductive type. -/ +private def mkFieldDepthsTerm + (indVal : InductiveVal) (typeParamNames : Array Name) : TermElabM Term := do + let ctorTerms ← indVal.ctors.mapM fun ctorName => do + let ctorInfo ← getConstInfoCtor ctorName + liftMetaM (mkCtorFieldDepthsTerm ctorInfo typeParamNames) + `(#[$(ctorTerms.toArray),*]) + +/-- Build the auxiliary `enc` function definition for `indVal`. -/ +private def mkStrEncAuxFun (ctx : Deriving.Context) (i : Nat) : TermElabM Command := do + let auxFunName := ctx.auxFunNames[i]! + let indVal := ctx.typeInfos[i]! + let header ← mkHeader ``StrEnc 1 indVal + let body ← mkStrEncMatch header indVal + `(private def $(mkIdent auxFunName) $header.binders:bracketedBinder* : String := $body) + +open TSyntax.Compat in +/-- Build `instance` commands that wire the aux function into the `StrEnc` typeclass. -/ +private def mkStrEncInstanceCmds (ctx : Deriving.Context) (typeNames : Array Name) : + TermElabM (Array Command) := do + let mut instances := #[] + for i in [:ctx.typeInfos.size] do + let indVal := ctx.typeInfos[i]! + if typeNames.contains indVal.name then + let auxFunName := ctx.auxFunNames[i]! + let argNames ← mkInductArgNames indVal + let binders ← mkImplicitBinders argNames + let binders := binders ++ (← mkInstImplicitBinders ``StrEnc indVal argNames) + let indType ← mkInductiveApp indVal argNames + let type ← `(StrEnc $indType) + -- `mkImplicitBinders` uses `mkFreshUserName`; the resulting binder names (e.g. `α`) + -- must be reconstructed from `argNames` because we generate instance commands BEFORE + -- aux-function commands (see `mkStrEncCmds`), so `α` is still fresh here. + -- NOTE: `mkInductArgNames` returns ONLY type-parameter names (no universe levels), + -- so `argNames.length = indVal.numParams`; no offset by `levelParams.length` needed. + let typeParamNames := argNames.extract 0 indVal.numParams + let depthTerm ← mkTypeDepthTerm indVal typeParamNames + let fieldDepthsTerm ← mkFieldDepthsTerm indVal typeParamNames + let instCmd ← `(instance $binders:implicitBinder* : $type := + ⟨$(mkIdent auxFunName), $depthTerm, $fieldDepthsTerm⟩) + instances := instances.push instCmd + return instances + +/-- Gather all commands for deriving `StrEnc` for `indVal`. + Instance commands are generated FIRST (before aux-function commands use up fresh names + like `α` via `mkHeader`), so that `mkImplicitBinders` sees a clean name namespace and + the depth term names match the binder names. The aux-function commands are placed first + in the output so they are elaborated before the instance that references them. -/ +private def mkStrEncCmds (indVal : InductiveVal) (declNames : Array Name) : + TermElabM (Array Syntax) := do + let ctx ← mkContext ``StrEnc "strEnc" indVal.name + let instCmds ← mkStrEncInstanceCmds ctx declNames -- generated first: names still fresh + let funCmds ← Array.range ctx.typeInfos.size |>.mapM (mkStrEncAuxFun ctx) + return funCmds ++ instCmds -- aux functions emitted before the instance that uses them + +/-- Deriving handler: invoked when a user writes `deriving StrEnc` after an inductive type. -/ +private def deriveStrEnc (declNames : Array Name) : CommandElabM Bool := do + let mut seen : NameSet := {} + for declName in declNames do + if seen.contains declName then continue + let indVal ← getConstInfoInduct declName + if indVal.isRec then + logWarning s!"StrEnc: skipping {declName}, which is recursive \ + (use instStrEncList for List)" + return false + seen := seen.append (NameSet.ofList indVal.all) + let cmds ← liftTermElabM <| mkStrEncCmds indVal declNames + elabCommand <| mkNullNode cmds + return true + +end StrEncDeriving + +-- Register handler at *import* time (for files that import this module). +-- Note: `registerDerivingHandler` can only be called during initialization (enforced by +-- Lean 4), so `deriving StrEnc` does not work in the same file where the handler is +-- defined. Use `derive_StrEnc T` instead (defined below). +open Lean Elab Lean.Elab.Deriving in +initialize registerDerivingHandler ``StrEnc deriveStrEnc + +/-- `derive_StrEnc T` directly invokes the StrEnc derivation for the inductive type `T`, + bypassing `registerDerivingHandler`. Use this in the same file as the handler + (where `deriving StrEnc` would give "no handlers implemented"). -/ +syntax "derive_StrEnc" ident : command + +elab_rules : command + | `(command| derive_StrEnc $t:ident) => do + let _ ← deriveStrEnc #[t.getId] + +/-! ### SAT-related data types — using `deriving StrEnc` -/ + +/-- A propositional literal: a variable index tagged as positive or negative. + Constructor indices (0-based): `pos` = 0, `neg` = 1. -/ +inductive Literal : Type where + | pos : ℕ → Literal -- positive literal xₙ + | neg : ℕ → Literal -- negative literal ¬xₙ + deriving Repr +derive_StrEnc Literal + +/-- A clause is a disjunction of literals. -/ +abbrev Clause := List Literal + +/-- A propositional formula in CNF is a conjunction of clauses. -/ +abbrev Formula := List Clause + +/-- An assignment is the list of variable indices assigned `true`. -/ +abbrev Assignment := List ℕ + +/-- Input to the SAT checker: a formula paired with an assignment. + Encoded as a single-constructor inductive (constructor index = 0). -/ +inductive SATInput : Type where + | mk : Formula → Assignment → SATInput + deriving Repr +derive_StrEnc SATInput + +-- Clause, Formula, and Assignment inherit StrEnc from the List instance automatically. + +/-! #### Verification examples -/ + +section SATExamples + +-- ¬x₁ (neg, index 1; variable 1) → ((1)(1)) +#eval StrEnc.enc (Literal.neg 1) +-- expected: "((1)(1))" + +-- x₂ (pos, index 0; variable 2) → (()(2)) +#eval StrEnc.enc (Literal.pos 2) +-- expected: "(()(2))" + +-- Clause ¬x₁ ∨ x₂ = [neg 1, pos 2] +#eval StrEnc.enc ([Literal.neg 1, Literal.pos 2] : Clause) +-- expected: "(((1)(1))(()(2)))" + +-- Formula (¬x₁ ∨ x₂) ∧ (x₁ ∨ x₃) +#eval StrEnc.enc + ([[Literal.neg 1, Literal.pos 2], [Literal.pos 1, Literal.pos 3]] : Formula) +-- expected: "((((1)(1))(()(2)))((()(1))(()(11))))" + +end SATExamples + +/-! #### Example: user-defined type with a type parameter -/ + +/-- A simple tagged value, to show `deriving StrEnc` works for parametrised types. -/ +inductive Tagged (α : Type*) where + | val : α → Tagged α -- constructor index 0 + | pair : (List α) → α → Tagged α -- constructor index 1 +derive_StrEnc Tagged + +#eval StrEnc.enc (Tagged.val (42 : ℕ)) -- "(()(42))" ? let's check +#eval StrEnc.enc (Tagged.pair ([1]) (2 : ℕ)) -- "((1)(1)(2))" + +/-! ### Basic properties of the encoding -/ + +/-- Every `encNat` is enclosed in parentheses. -/ +theorem encNat_starts_with_paren (n : ℕ) : ∃ s, encNat n = "(" ++ s ++ ")" := + ⟨dyadicEnc n, rfl⟩ + +/-- Every list encoding is enclosed in parentheses. -/ +theorem encList_starts_with_paren [StrEnc α] (l : List α) : + ∃ s, StrEnc.enc l = "(" ++ s ++ ")" := + ⟨String.join (l.map StrEnc.enc), rfl⟩ + +/-- Every `Literal` encoding is enclosed in parentheses. -/ +theorem encLiteral_starts_with_paren (lit : Literal) : + ∃ s, StrEnc.enc lit = "(" ++ s ++ ")" := by + cases lit with + | pos n => exact ⟨encNat 0 ++ encNat n, rfl⟩ + | neg n => exact ⟨encNat 1 ++ encNat n, rfl⟩ + +/-- `dyadicEnc` only uses the characters `1` and `2`. -/ +theorem dyadicEnc_chars (n : ℕ) : + ∀ c ∈ (dyadicEnc n).toList, c = '1' ∨ c = '2' := by + induction n using Nat.strongRecOn with + | _ n ih => + intro c hc + match n with + | 0 => simp [dyadicEnc] at hc + | n + 1 => + by_cases h : (n + 1) % 2 = 1 + · -- Odd branch: dyadicEnc (n+1) = dyadicEnc ((n+1)/2) ++ "1" + -- Use conv_lhs to unfold only the LHS occurrence of dyadicEnc + have heq : dyadicEnc (n + 1) = dyadicEnc ((n + 1) / 2) ++ "1" := by + conv_lhs => unfold dyadicEnc; dsimp only + exact if_pos h + simp only [heq, String.toList_append, List.mem_append] at hc + rcases hc with hc | hc + · exact ih ((n + 1) / 2) (by omega) c hc + · simp at hc; exact .inl hc + · -- Even branch: dyadicEnc (n+1) = dyadicEnc ((n+1)/2 - 1) ++ "2" + have heq : dyadicEnc (n + 1) = dyadicEnc ((n + 1) / 2 - 1) ++ "2" := by + conv_lhs => unfold dyadicEnc; dsimp only + exact if_neg h + simp only [heq, String.toList_append, List.mem_append] at hc + rcases hc with hc | hc + · exact ih ((n + 1) / 2 - 1) (by omega) c hc + · simp at hc; exact .inr hc diff --git a/TM.lean b/TM.lean new file mode 100644 index 0000000000..6695dbde89 --- /dev/null +++ b/TM.lean @@ -0,0 +1,337 @@ +import Cslib.Computability.Machines.MultiTapeTuring.Data +import Mathlib.Data.List.Basic + +/-! +# Turing Machines over Character Tapes + +We define an abstract model of single-tape Turing machines over character alphabets, +give elementary operations as `sorry`-defined constants with stated semantics, and +build derived *skip* machines for navigating encoded values. + +## Tape model + +A `Tape` is a pair `⟨left, right⟩` where +- `left` is the portion to the *left* of the head, stored in **reverse** order + (`left.head?` is the cell immediately left of the head), and +- `right` is the portion at and to the *right* of the head + (`right.head?` is the current cell, if any). + +## Machine model + +A `TM` is an opaque type representing a partial Turing machine. Use `TM.eval` to +execute it. `none` means the machine diverges or encounters an invalid configuration. +Sequential composition `m₁ ;; m₂` is `Option`-monadic bind on `TM.eval`. + +## Skip machines + +For each encodable type `α` with `[StrEnc α]` giving its maximum parenthesis nesting +depth `StrEnc.depth`, the machine `skip α = skipRight StrEnc.depth` moves the head +from the opening `(` of an encoded value to the first character after the closing `)` + no runtime counter needed, since the depth is a compile-time constant. +-/ + +/-! ## Tape -/ + +/-- A Turing machine tape. + `left` is stored reversed so that `left.head?` is the cell immediately left of the head. + `right.head?` is the current cell (if any). -/ +structure Tape where + left : List Char + right : List Char + deriving Repr, DecidableEq + +/-! ## TM: opaque Turing machine type -/ + +/-- An opaque Turing machine. The internal implementation is hidden; use `TM.eval` to run it. -/ +structure TM where + private mk :: + private runFn : Tape → Option Tape + +namespace TM + +/-- Execute a TM on a tape. Returns `none` if the machine diverges or gets stuck. -/ +def eval (tm : TM) (t : Tape) : Option Tape := tm.runFn t + +@[simp] lemma eval_mk (f : Tape → Option Tape) (t : Tape) : (TM.mk f).eval t = f t := rfl + +/-- Two TMs are equal iff they agree on all inputs. -/ +@[ext] theorem ext {m₁ m₂ : TM} (h : ∀ t, m₁.eval t = m₂.eval t) : m₁ = m₂ := by + cases m₁; cases m₂; simp only [eval] at h; exact congrArg TM.mk (funext h) + +/-! ## Composition -/ + +/-- Sequential composition: run `m₁` then feed its output to `m₂`. -/ +def seq (m₁ m₂ : TM) : TM := TM.mk (fun t => m₁.eval t >>= m₂.eval) + +infixl:55 " ;; " => seq + +@[simp] lemma seq_eval (m₁ m₂ : TM) (t : Tape) : (m₁ ;; m₂).eval t = m₁.eval t >>= m₂.eval := rfl + +/-- The identity machine. -/ +def idMach : TM := TM.mk (fun t => some t) + +@[simp] lemma idMach_eval (t : Tape) : idMach.eval t = some t := rfl + +@[simp] lemma seq_idMach_right (m : TM) : (m ;; idMach) = m := by + ext t; simp [seq_eval]; cases m.eval t <;> rfl + +@[simp] lemma seq_idMach_left (m : TM) : (idMach ;; m) = m := by + ext t; simp [seq_eval] + +@[simp] lemma seq_assoc (m₁ m₂ m₃ : TM) : ((m₁ ;; m₂) ;; m₃) = (m₁ ;; (m₂ ;; m₃)) := by + ext t; simp [seq_eval]; cases m₁.eval t <;> simp + +/-! ## Elementary machines (definitions deferred — semantics stated as lemmas) -/ + +/-- Move the head one cell to the right. -/ +def right : TM := sorry + +/-- Move the head one cell to the left. -/ +def left : TM := sorry + +/-- While the cell at the head equals `c`, execute `tm`. -/ +def while_eq (c : Char) (tm : TM) : TM := sorry + +/-- While the cell at the head differs from `c`, execute `tm`. -/ +def while_neq (c : Char) (tm : TM) : TM := sorry + +/-! ### Semantics of elementary machines (sorry-proved) -/ + +@[simp] +lemma right_spec (l : List Char) (c : Char) (r : List Char) : + right.eval ⟨l, c :: r⟩ = some ⟨c :: l, r⟩ := sorry + +@[simp] +lemma left_spec (l : List Char) (c : Char) (r : List Char) : + left.eval ⟨c :: l, r⟩ = some ⟨l, c :: r⟩ := sorry + +/-- `while_eq` terminates immediately when the head cell differs from `c`. -/ +lemma while_eq_done {c : Char} {tm : TM} {l : List Char} {c' : Char} {r : List Char} + (h : c' ≠ c) : + (while_eq c tm).eval ⟨l, c' :: r⟩ = some ⟨l, c' :: r⟩ := sorry + +/-- `while_eq` runs one step of `tm` when the head cell equals `c`, then loops. -/ +lemma while_eq_step {c : Char} {tm : TM} {l : List Char} {r : List Char} {t' : Tape} + (hstep : tm.eval ⟨l, c :: r⟩ = some t') : + (while_eq c tm).eval ⟨l, c :: r⟩ = (while_eq c tm).eval t' := sorry + +/-- `while_neq` terminates immediately when the head cell equals `c`. -/ +@[simp] +lemma while_neq_done {c : Char} {tm : TM} {l : List Char} {r : List Char} : + (while_neq c tm).eval ⟨l, c :: r⟩ = some ⟨l, c :: r⟩ := sorry + +/-- `while_neq` runs one step of `tm` when the head cell differs from `c`, then loops. -/ +lemma while_neq_step {c : Char} {tm : TM} {l : List Char} {c' : Char} {r : List Char} + {t' : Tape} (h : c' ≠ c) (hstep : tm.eval ⟨l, c' :: r⟩ = some t') : + (while_neq c tm).eval ⟨l, c' :: r⟩ = (while_neq c tm).eval t' := sorry + +/-! ## Parenthesis nesting depth -/ + +/-- Maximum parenthesis nesting depth of a string. + State: (current depth, maximum depth seen so far). -/ +def parenDepth (s : String) : ℕ := + (s.toList.foldl + (fun st c => + if c = '(' then (st.1 + 1, max st.2 (st.1 + 1)) + else if c = ')' then (st.1 - 1, st.2) + else st) + (0, 0)).2 + +section DepthExamples +#eval parenDepth "()" -- 1 (= enc 0 : ℕ) +#eval parenDepth "(11)" -- 1 (= enc 3 : ℕ) +#eval parenDepth "(()(1))" -- 2 (= enc (Literal.pos 1)) +#eval parenDepth "((1)(1))" -- 2 (= enc (Literal.neg 1)) +#eval parenDepth "(((1)(1)))" -- 3 +end DepthExamples + +/-- A string is a *well-formed encoding*: nonempty, starts with `(`, ends with `)`. -/ +def WellFormed (s : String) : Prop := + s.toList ≠ [] ∧ s.toList.head? = some '(' ∧ s.toList.getLast? = some ')' + +/-! ## `EncDepth` typeclass -/ + +/-- `EncDepth α` asserts that: + (1) every encoded value of type `α` has parenthesis nesting depth ≤ `StrEnc.depth α`, and + (2) every encoded value is well-formed (starts with `(`, ends with `)`). + + The depth bound is carried in `StrEnc.depth`. These two properties together guarantee + that `skipRight (StrEnc.depth α)` correctly skips over any encoded `α` value. -/ +class EncDepth (α : Type*) [StrEnc α] where + depth_bound : ∀ x : α, parenDepth (StrEnc.enc x) ≤ StrEnc.depth (α := α) + well_formed : ∀ x : α, WellFormed (StrEnc.enc x) + +/-! ### Standard `EncDepth` instances -/ + +/-- Natural numbers: `encNat n = "(" ++ dyadicEnc n ++ ")"`, `StrEnc.depth = 1`. + The dyadic digits `1` and `2` contain no parentheses, so depth = 1. -/ +instance : EncDepth ℕ where + depth_bound := sorry + well_formed := sorry + +/-- Lists: `enc l = "(" ++ enc x₁ ++ … ++ ")"`. + Each `enc xᵢ` has depth ≤ `StrEnc.depth α`; the outer `()` adds one level, + giving `StrEnc.depth α + 1 = StrEnc.depth (List α)`. -/ +instance [StrEnc α] [EncDepth α] : EncDepth (List α) where + depth_bound := sorry + well_formed := sorry + +/-! ## Skip machines -/ + +/-- `skipRight d` moves the head from the `(` of a well-formed encoding of depth ≤ `d` + to the first character after the closing `)`. + + ``` + skipRight 0 = right -- not used in practice + skipRight (d+1) = right ;; while_neq ')' (skipRight d) ;; right + ``` + + Correctness: inside any depth-`(d+1)` encoding, the content consists of + depth-`d` sub-encodings; `while_neq ')' (skipRight d)` iterates `skipRight d` + on each sub-encoding until the closing `)` is reached. -/ +def skipRight : ℕ → TM + | 0 => right + | d + 1 => right ;; while_neq ')' (skipRight d) ;; right + +/-- The canonical skip machine for type `α`: moves past one encoded `α` value. + Uses `StrEnc.depth` as the parenthesis nesting depth bound. -/ +def skip (α : Type*) [StrEnc α] [EncDepth α] : TM := + skipRight (StrEnc.depth (α := α)) + +/-! ### Unfolding lemmas -/ + +lemma skipRight_zero : skipRight 0 = right := rfl + +lemma skipRight_succ (d : ℕ) : + skipRight (d + 1) = (right ;; while_neq ')' (skipRight d) ;; right) := rfl + +lemma skip_Nat_eq : skip ℕ = (right ;; while_neq ')' right ;; right) := rfl + +lemma skip_List_eq (α : Type*) [StrEnc α] [EncDepth α] : + skip (List α) = (right ;; while_neq ')' (skip α) ;; right) := rfl + +/-! ## Key correctness theorem -/ + +/-- `skipRight d` correctly skips any well-formed string of depth ≤ `d`. + Starting with the head on the opening `(`, it ends with the head on + the first character after the closing `)`. -/ +theorem skipRight_spec {d : ℕ} {s : String} + (hwf : WellFormed s) + (hdep : parenDepth s ≤ d) + (l r : List Char) : + (skipRight d).eval ⟨l, s.toList ++ r⟩ = some ⟨s.toList.reverse ++ l, r⟩ := sorry +/- + Proof sketch (by strong induction on d): + * Base case (d = 0): parenDepth s ≤ 0 contradicts WellFormed (which forces '(' at head, + giving parenDepth ≥ 1). Vacuously true. + * Inductive step (d → d+1): + Since s is well-formed, write s = "(" ++ inner ++ ")" where inner is a concatenation + of well-formed sub-strings each of depth ≤ d. + - `right` moves past '(', leaving head on inner ++ [')'] ++ r. + - `while_neq ')'` iterates: each time head is on '(' (start of a sub-encoding of depth ≤ d), + `skipRight d` (IH) advances past the entire sub-encoding. This repeats until head is ')'. + - The final `right` moves past ')'. + - The accumulated `left` portion equals s.toList.reverse ++ l. +-/ + +/-- `skip α` correctly skips any encoded value of type `α`. -/ +theorem skip_spec {α : Type*} [StrEnc α] [EncDepth α] (x : α) (l r : List Char) : + (skip α).eval ⟨l, (StrEnc.enc x).toList ++ r⟩ = + some ⟨(StrEnc.enc x).toList.reverse ++ l, r⟩ := + skipRight_spec (EncDepth.well_formed x) (EncDepth.depth_bound x) l r + +/-! ## Navigation: `toArg` -/ + +/-- `toArg α ctorIdx fieldIdx` positions the head at the `fieldIdx`-th argument (0-indexed) + of the encoding of a value of type `α` whose constructor has index `ctorIdx`. + The head must start on the opening `(` of the encoded value. + + The skip machines for each field are derived automatically from `StrEnc.fieldDepths`: + ``` + toArg α ctorIdx fieldIdx := + right ;; -- move past the opening '(' + skip ℕ ;; -- skip the constructor index + skipRight d₀ ;; -- skip field 0 (if fieldIdx > 0) + skipRight d₁ ;; -- skip field 1 (if fieldIdx > 1) + … + skipRight dᵢ₋₁ -- skip field i-1 + ``` + where `dⱼ = (StrEnc.fieldDepths (α := α))[ctorIdx][j]`. + + Semantics (informal): + ``` + (toArg α ctorIdx fieldIdx).eval ⟨w₁, enc(c a₀ … aₙ) ++ w₂⟩ = + some ⟨enc(aᵢ₋₁).rev ++ … ++ enc(a₀).rev ++ enc(idx).rev ++ ['('] ++ w₁, + enc(aᵢ) ++ enc(aᵢ₊₁) ++ … ++ [')'] ++ w₂⟩ + ``` -/ +def toArg (α : Type*) [StrEnc α] (ctorIdx fieldIdx : ℕ) : TM := + let depths := ((StrEnc.fieldDepths (α := α)).get? ctorIdx |>.getD #[]).toList + let skipFields := depths.map skipRight + right ;; skip ℕ ;; (skipFields.take fieldIdx).foldl seq idMach + +/-- `toArg_spec`: `toArg` correctly positions the head on argument `fieldIdx`. + After execution the left tape holds (reversed): the first `fieldIdx` field encodings, + the constructor-index encoding, and the opening `(`; + the right tape starts with the `fieldIdx`-th field encoding then the rest and `)`. -/ +theorem toArg_spec + {α : Type*} [StrEnc α] [EncDepth α] + (ctorIdx fieldIdx : ℕ) + (l r : List Char) + (fieldEncodings : List String) + (hfd : ∀ j < fieldIdx, + (StrEnc.fieldDepths (α := α)).get? ctorIdx |>.getD #[] |>.get? j |>.getD 0 = + parenDepth (fieldEncodings.get? j |>.getD "")) + (hlen : fieldIdx ≤ fieldEncodings.length) : + let input := Tape.mk l + (("(" ++ encNat ctorIdx ++ String.join fieldEncodings ++ ")").toList ++ r) + let left' := (String.join (fieldEncodings.take fieldIdx)).toList.reverse ++ + (encNat ctorIdx).toList.reverse ++ ['('] ++ l + let right' := (String.join (fieldEncodings.drop fieldIdx)).toList ++ [')'] ++ r + (toArg α ctorIdx fieldIdx).eval input = some (Tape.mk left' right') := sorry + +/-! ## `EncDepth` instances for SAT types -/ + +/-- A `Literal` encoding has depth 2. + `enc (pos n) = "(" ++ encNat 0 ++ encNat n ++ ")"` contains two depth-1 sub-encodings, + so depth = 1 + 1 = 2. -/ +instance : EncDepth Literal where + depth_bound := sorry + well_formed := sorry + +-- `Clause = List Literal`: depth 2 + 1 = 3 +instance : EncDepth (List Literal) where + depth_bound := sorry + well_formed := sorry + +-- `Formula = List Clause = List (List Literal)`: depth 3 + 1 = 4 +instance : EncDepth (List (List Literal)) where + depth_bound := sorry + well_formed := sorry + +-- `Assignment = List ℕ`: depth 1 + 1 = 2 +instance instEncDepthAssignment : EncDepth (List ℕ) where + depth_bound := sorry + well_formed := sorry + +/-- `SATInput.mk` packs a `Formula` and an `Assignment` into one constructor. + `enc (SATInput.mk φ σ) = "(" ++ encNat 0 ++ enc φ ++ enc σ ++ ")"`. + depth = 1 + max(depth(Formula), depth(Assignment)) = 1 + max(4, 2) = 5. -/ +instance : EncDepth SATInput where + depth_bound := sorry + well_formed := sorry + +/-! ### Sanity checks -/ + +section DepthChecks +#eval parenDepth (StrEnc.enc (Literal.neg 1)) -- 2 ✓ +#eval parenDepth (StrEnc.enc ([Literal.neg 1] : Clause)) -- 3 ✓ +#eval parenDepth (StrEnc.enc ([[Literal.neg 1]] : Formula)) -- 4 ✓ +#eval parenDepth (StrEnc.enc (SATInput.mk [[Literal.neg 1]] [0])) -- 5 ✓ +#eval StrEnc.depth (α := ℕ) -- 1 ✓ +#eval StrEnc.depth (α := Literal) -- should be 2 +#eval StrEnc.depth (α := Clause) -- should be 3 +#eval StrEnc.depth (α := Formula) -- should be 4 +#eval StrEnc.depth (α := SATInput) -- should be 5 +end DepthChecks + +end TM diff --git a/TestNatLemmas.lean b/TestNatLemmas.lean new file mode 100644 index 0000000000..b693f15db0 --- /dev/null +++ b/TestNatLemmas.lean @@ -0,0 +1,3 @@ +import Mathlib + +#check Nat.not_eq_zero_of_lt diff --git a/import Mathlib.Data.List.Basic; #check List.append_right_inj b/import Mathlib.Data.List.Basic; #check List.append_right_inj new file mode 100644 index 0000000000..29fc63c13c --- /dev/null +++ b/import Mathlib.Data.List.Basic; #check List.append_right_inj @@ -0,0 +1,33 @@ +// Lean compiler output +// Module: TestLemmas +// Imports: public import Init public import Mathlib +#include +#if defined(__clang__) +#pragma clang diagnostic ignored "-Wunused-parameter" +#pragma clang diagnostic ignored "-Wunused-label" +#elif defined(__GNUC__) && !defined(__CLANG__) +#pragma GCC diagnostic ignored "-Wunused-parameter" +#pragma GCC diagnostic ignored "-Wunused-label" +#pragma GCC diagnostic ignored "-Wunused-but-set-variable" +#endif +#ifdef __cplusplus +extern "C" { +#endif +lean_object* initialize_Init(uint8_t builtin); +lean_object* initialize_mathlib_Mathlib(uint8_t builtin); +static bool _G_initialized = false; +LEAN_EXPORT lean_object* initialize_TestLemmas(uint8_t builtin) { +lean_object * res; +if (_G_initialized) return lean_io_result_mk_ok(lean_box(0)); +_G_initialized = true; +res = initialize_Init(builtin); +if (lean_io_result_is_error(res)) return res; +lean_dec_ref(res); +res = initialize_mathlib_Mathlib(builtin); +if (lean_io_result_is_error(res)) return res; +lean_dec_ref(res); +return lean_io_result_mk_ok(lean_box(0)); +} +#ifdef __cplusplus +} +#endif