diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index e82728faf3..c27b306d14 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -1,5 +1,5 @@ # For an overview of the governance model of cslib, please refer to /GOVERNANCE.md and /DECISION_MAKING.md -* @fmontesi @chenson2018 @kim-em @arademaker @sorrachai +* @fmontesi @chenson2018 @kim-em @arademaker @SamuelSchlesinger @sorrachai /.github/CODEOWNERS @fmontesi /DECISION_MAKING.md @fmontesi diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000000..f8a3e493fb --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,25 @@ +version: 2 +updates: + # Keep action pins fresh. Grouped so that all bumps land in a single weekly PR, + # which bounds the number of full Lean CI builds this triggers. + - package-ecosystem: github-actions + directory: / + schedule: + interval: weekly + groups: + actions: + patterns: ["*"] + commit-message: + prefix: ci + + # Python packages installed by workflows (see requirements.txt in this directory). + # Major bumps are left for a human to review. + - package-ecosystem: pip + directory: /.github + schedule: + interval: weekly + ignore: + - dependency-name: "*" + update-types: ["version-update:semver-major"] + commit-message: + prefix: ci diff --git a/.github/requirements.txt b/.github/requirements.txt new file mode 100644 index 0000000000..d0dbe8356c --- /dev/null +++ b/.github/requirements.txt @@ -0,0 +1 @@ +zulip==0.9.1 diff --git a/.github/workflows/actionlint.yml b/.github/workflows/actionlint.yml new file mode 100644 index 0000000000..a8a3f0a061 --- /dev/null +++ b/.github/workflows/actionlint.yml @@ -0,0 +1,31 @@ +name: actionlint + +on: + push: + branches: + - main + paths: + - '.github/workflows/**' + pull_request: + paths: + - '.github/workflows/**' + workflow_dispatch: + +permissions: + contents: read + +jobs: + actionlint: + name: Lint workflow files + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@de0fac2e4500dabe0009e67214ff5f5447ce83dd # v6.0.2 + with: + sparse-checkout: | + .github/workflows + + # Also runs shellcheck over every `run:` block and pyflakes over + # `shell: python` steps. + - uses: raven-actions/actionlint@3d39aea434753780c3b3d4a1a31c854b4dbf49d7 # v2.2.0 + with: + version: 1.7.12 diff --git a/.github/workflows/bump_toolchain_nightly-testing.yml b/.github/workflows/bump_toolchain_nightly-testing.yml index 7bab15c8fc..894c166363 100644 --- a/.github/workflows/bump_toolchain_nightly-testing.yml +++ b/.github/workflows/bump_toolchain_nightly-testing.yml @@ -45,7 +45,7 @@ jobs: GH_TOKEN: ${{ steps.app-token.outputs.token }} run: | # Extract date from RELEASE_TAG (format: nightly-YYYY-MM-DD) - DATE_PART=$(echo "$RELEASE_TAG" | sed 's/nightly-//') + DATE_PART="${RELEASE_TAG#nightly-}" NIGHTLY_TESTING_TAG="nightly-testing-${DATE_PART}" echo "NIGHTLY_TESTING_TAG=$NIGHTLY_TESTING_TAG" >> "${GITHUB_ENV}" diff --git a/.github/workflows/lean_action_ci.yml b/.github/workflows/lean_action_ci.yml index d5ca8cefab..95bc25bd12 100644 --- a/.github/workflows/lean_action_ci.yml +++ b/.github/workflows/lean_action_ci.yml @@ -14,10 +14,6 @@ jobs: runs-on: ubuntu-latest steps: - uses: actions/checkout@v4 - - name: Set TEST_ARGS manually - run: | - echo "TEST_ARGS='--wfail --iofail'" >> $GITHUB_ENV - shell: bash - uses: leanprover/lean-action@v1 with: build-args: "--wfail --iofail" diff --git a/.github/workflows/report_failures_nightly-testing.yml b/.github/workflows/report_failures_nightly-testing.yml index edeeb91682..c5a58e0125 100644 --- a/.github/workflows/report_failures_nightly-testing.yml +++ b/.github/workflows/report_failures_nightly-testing.yml @@ -80,7 +80,7 @@ jobs: # Now post a success message to zulip, if the last message there is not a success message. # https://chat.openai.com/share/87656d2c-c804-4583-91aa-426d4f1537b3 - name: Install Zulip API client - run: pip install zulip + run: pip install -r .github/requirements.txt - name: Check last message and post if necessary env: @@ -268,9 +268,10 @@ jobs: BUMP_VERSION: ${{ steps.bump_version.outputs.result }} BUMP_BRANCH: ${{ steps.latest_bump_branch.outputs.result }} SHA: ${{ env.SHA }} + ZULIP_API_KEY: ${{ secrets.ZULIP_API_KEY }} run: | echo "Installing zulip CLI..." - pip install zulip + pip install -r .github/requirements.txt echo "Configuring git identity for mathlib4-bot..." git config --global user.name "mathlib4-bot" git config --global user.email "github-mathlib4-bot@leanprover.zulipchat.com" @@ -278,7 +279,7 @@ jobs: { echo "[api]" echo "email=github-mathlib4-bot@leanprover.zulipchat.com" - echo "key=${{ secrets.ZULIP_API_KEY }}" + echo "key=$ZULIP_API_KEY" echo "site=https://leanprover.zulipchat.com" } > ~/.zuliprc chmod 600 ~/.zuliprc diff --git a/Cslib.lean b/Cslib.lean index 8cfe47e010..9eb830df77 100644 --- a/Cslib.lean +++ b/Cslib.lean @@ -31,10 +31,23 @@ public import Cslib.Computability.Automata.NA.ToDA public import Cslib.Computability.Automata.NA.Total public import Cslib.Computability.Automata.Transducers.Transducer public import Cslib.Computability.Automata.TwoWayNA.Basic +public import Cslib.Computability.Automata.TwoWayNA.ComplToNA +public import Cslib.Computability.Automata.TwoWayNA.OfNA public import Cslib.Computability.Circuit.Basic +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Boolean.Counting +public import Cslib.Computability.Circuit.Boolean.Lupanov +public import Cslib.Computability.Circuit.Boolean.LupanovConstruction +public import Cslib.Computability.Circuit.Boolean.Shannon +public import Cslib.Computability.Circuit.Boolean.Synthesis +public import Cslib.Computability.Circuit.Counting +public import Cslib.Computability.Circuit.Finite public import Cslib.Computability.Circuit.Homomorphism +public import Cslib.Computability.Circuit.Normalization public import Cslib.Computability.Circuit.Program +public import Cslib.Computability.Circuit.Shannon public import Cslib.Computability.Circuit.Signature +public import Cslib.Computability.Circuit.Synthesis public import Cslib.Computability.Circuit.Wire public import Cslib.Computability.Distributed.FLP.Algorithm public import Cslib.Computability.Distributed.FLP.CanReachVia @@ -44,8 +57,9 @@ public import Cslib.Computability.Distributed.FLP.Impossibility public import Cslib.Computability.Distributed.FLP.OnePseudoConsensus public import Cslib.Computability.Distributed.FLP.PseudoConsensus public import Cslib.Computability.Distributed.FLP.ZeroConsensus +public import Cslib.Computability.Languages.Congruences.Basic public import Cslib.Computability.Languages.Congruences.BuchiCongruence -public import Cslib.Computability.Languages.Congruences.RightCongruence +public import Cslib.Computability.Languages.Congruences.MyhillCongruence public import Cslib.Computability.Languages.ExampleEventuallyZero public import Cslib.Computability.Languages.Language public import Cslib.Computability.Languages.LanguageHom @@ -54,10 +68,34 @@ public import Cslib.Computability.Languages.OmegaLanguage public import Cslib.Computability.Languages.OmegaRegularLanguage public import Cslib.Computability.Languages.RegularLanguage public import Cslib.Computability.Languages.SafetyLiveness +public import Cslib.Computability.Languages.SyntacticMonoid +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Ite +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Loop +public import Cslib.Computability.Machines.Turing.MultiTape.ConfigBound public import Cslib.Computability.Machines.Turing.MultiTape.Configuration public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Cslib.Computability.Machines.Turing.MultiTape.DeterministicToNondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.Encodings.Option public import Cslib.Computability.Machines.Turing.MultiTape.Nondeterministic +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Repeat +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas public import Cslib.Computability.Machines.Turing.SingleTape.Defs public import Cslib.Computability.Machines.Turing.SingleTape.Deterministic @@ -83,12 +121,16 @@ public import Cslib.Foundations.Combinatorics.InfiniteGraphRamsey public import Cslib.Foundations.Control.Monad.Free public import Cslib.Foundations.Control.Monad.Free.Effects public import Cslib.Foundations.Control.Monad.Free.Fold +public import Cslib.Foundations.Control.Monad.IsMonadHom +public import Cslib.Foundations.Control.Monad.IsMonadHom.List public import Cslib.Foundations.Data.BiTape public import Cslib.Foundations.Data.DecidableEqZero public import Cslib.Foundations.Data.FinFun.Basic public import Cslib.Foundations.Data.FinFun.Update public import Cslib.Foundations.Data.HasFresh public import Cslib.Foundations.Data.List.IsChainFromTo +public import Cslib.Foundations.Data.Nat.Asymptotics +public import Cslib.Foundations.Data.Nat.Factorial public import Cslib.Foundations.Data.Nat.Segment public import Cslib.Foundations.Data.OmegaSequence.Defs public import Cslib.Foundations.Data.OmegaSequence.Flatten diff --git a/Cslib/Algorithms/CCS/VendingMachine.lean b/Cslib/Algorithms/CCS/VendingMachine.lean index 08bb842513..6dcfd1d921 100644 --- a/Cslib/Algorithms/CCS/VendingMachine.lean +++ b/Cslib/Algorithms/CCS/VendingMachine.lean @@ -48,27 +48,27 @@ inductive Constant | vm /-- The vending machine process. -/ -def vm : Process String Constant := const .vm +def vm : Process String Constant := `(CCS| const .vm) /-! ## Deterministic vending machine -/ /-- Constant definitions: vm = coin.(tea.VM + coffee.VM) -/ @[local grind =] def vendingDefs : Constant → Option (Process String Constant) - | .vm => some <| pre Coin (choice (pre Tea (const .vm)) (pre Coffee (const .vm))) + | .vm => some <| `(CCS| Coin. ((Tea. const .vm) + (Coffee. const .vm))) /-- The LTS of CCS for the deterministic vending machine. -/ abbrev ltsD := CCS.lts (defs := vendingDefs) /-- VM can perform a coin action. -/ -example : ltsD.Tr vm Coin (choice (pre Tea (const .vm)) (pre Coffee (const .vm))) := +example : ltsD.Tr vm Coin `(CCS| (Tea. (const .vm)) + (Coffee. (const .vm))) := Tr.const rfl Tr.pre /-! ## Nondeterministic vending machine -/ /-- vm = coin.tea.VM + coin.coffee.VM -/ def vendingDefsND : Constant → Option (Process String Constant) - | .vm => some <| (choice (pre Coin (pre Tea (const .vm))) (pre Coin (pre Coffee (const .vm)))) + | .vm => some <| `(CCS| (Coin. Tea. const .vm) + (Coin. Coffee. const .vm)) /-- The LTS of CCS for the nondeterministic vending machine. -/ abbrev ltsND := CCS.lts (defs := vendingDefsND) @@ -78,8 +78,8 @@ open LTS LTS.IsBisimulation LTS.Bisimilarity /-- The deterministic and nondeterministic vending machines are not bisimilar. -/ theorem vm_ltsD_ltsND_not_bisim : ¬(vm ~[ltsD, ltsND] vm) := by rintro ⟨r, hr, hbisim⟩ - let p₁ := (choice (pre Tea (const Constant.vm)) (pre Coffee (const Constant.vm))) - let q₁ := (pre Tea (const Constant.vm)) + let p₁ := `(CCS| (Tea. const Constant.vm) + (Coffee. const Constant.vm)) + let q₁ := `(CCS| Tea. const Constant.vm) have ltsD_vm_deterministic : ltsD.DeterministicStateLabel vm Coin := by intro _ _ htr₁ htr₂ grind [const_tr htr₁, const_tr htr₂] @@ -90,7 +90,7 @@ theorem vm_ltsD_ltsND_not_bisim : ¬(vm ~[ltsD, ltsND] vm) := by (.const rfl .pre) (.const rfl (.choiceL .pre)) have hp₁q₁ : p₁ ~[ltsD, ltsND] q₁ := by grind - have hp₁coffee : ltsD.Tr p₁ Coffee (const Constant.vm) := .choiceR .pre + have hp₁coffee : ltsD.Tr p₁ Coffee (.const .vm) := .choiceR .pre grind [hp₁q₁.follow_fst] end Cslib.Algorithms.CCS.VendingMachine diff --git a/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean b/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean index 44a703f0bc..2a1384cdc4 100644 --- a/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean +++ b/Cslib/Algorithms/Lean/MergeSort/MergeSort.lean @@ -40,18 +40,14 @@ open List in @[simp, grind =] theorem ret_mergeM {T} [AddMonoid T] (xs ys : List α) (le : α → α → TimeM T Bool) : ⟪List.mergeM xs ys le⟫ = List.merge xs ys (fun x y => ⟪le x y⟫) := by - fun_induction merge with grind [mergeM, nil_merge, merge_right, cons_merge_cons] + simpa using Id.ext_iff.1 <| isMonadHom_pure_ret.map_listMergeM xs ys le open List in /-- `TimeM.ret` passes through `List.mergeSortM` into the comparator. -/ @[simp] theorem ret_mergeSortM {T} [AddMonoid T] (xs : List α) (le : α → α → TimeM T Bool) : ⟪List.mergeSortM xs le⟫ = List.mergeSort xs (fun x y => ⟪le x y⟫) := by - fun_induction List.mergeSortM with - | case1 | case2 => simp - | case3 a b xs le iha ihb => - simp only [ret_bind, ret_mergeM, mergeSort] - rw [iha, ihb] + simpa using Id.ext_iff.1 <| isMonadHom_pure_ret.map_listMergeSortM xs le variable [LinearOrder α] diff --git a/Cslib/Algorithms/Lean/Sort/Insertion.lean b/Cslib/Algorithms/Lean/Sort/Insertion.lean index 8c571cf86a..33a0e9ce3b 100644 --- a/Cslib/Algorithms/Lean/Sort/Insertion.lean +++ b/Cslib/Algorithms/Lean/Sort/Insertion.lean @@ -6,6 +6,7 @@ Authors: Jeremy Avigad, Eric Wieser module public import Mathlib.Data.List.Sort +public import Cslib.Foundations.Control.Monad.IsMonadHom import Cslib.Init @@ -18,18 +19,20 @@ algorithmic analysis. public section +open Cslib (IsMonadHom) + namespace List -variable {m} [Monad m] (r : α → α → m Bool) +variable {m n} [Monad m] [Monad n] (r : α → α → m Bool) /-- A monadic version of `List.orderedInsert`. -/ def orderedInsertM (a : α) : List α → m (List α) | [] => return [a] | b :: l => do if ← r a b then return a :: b :: l else return b :: (← orderedInsertM a l) -@[simp] theorem orderedInsertM_nil (a : α) : orderedInsertM r a [] = pure [a] := by +@[simp, grind =] theorem orderedInsertM_nil (a : α) : orderedInsertM r a [] = pure [a] := by rfl -@[simp] theorem orderedInsertM_cons (a b : α) (l : List α) : +@[simp, grind =] theorem orderedInsertM_cons (a b : α) (l : List α) : orderedInsertM r a (b :: l) = do if ← r a b then return a :: b :: l else return b :: (← orderedInsertM r a l) := by rfl @@ -45,6 +48,12 @@ theorem idRun_orderedInsertM (r : α → α → Id Bool) (a : α) (xs : List α) Id.run (orderedInsertM r a xs) = orderedInsert (fun x y => Id.run <| r x y) a xs := orderedInsertM_pure _ _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_orderedInsertM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (r : α → α → m Bool) (a : α) (xs : List α) : + f (orderedInsertM r a xs) = orderedInsertM (fun x y => f (r x y)) a xs := by + fun_induction orderedInsertM r a xs with grind + /-- A monadic version of `List.insertionSort`. -/ def insertionSortM : List α → m (List α) | [] => return [] @@ -66,4 +75,10 @@ theorem idRun_insertionSortM (xs : List α) (r : α → α → Id Bool) : Id.run (insertionSortM r xs) = insertionSort (fun x y => Id.run <| r x y) xs := insertionSortM_pure _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_listInsertionSortM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (r : α → α → m Bool) (xs : List α) : + f (insertionSortM r xs) = insertionSortM (fun x y => f (r x y)) xs := by + fun_induction insertionSortM r xs with simp [hf.map_pure, hf.map_bind, hf.map_orderedInsertM, *] + end List diff --git a/Cslib/Algorithms/Lean/Sort/Merge.lean b/Cslib/Algorithms/Lean/Sort/Merge.lean index a1f4c68d72..e64c6523b4 100644 --- a/Cslib/Algorithms/Lean/Sort/Merge.lean +++ b/Cslib/Algorithms/Lean/Sort/Merge.lean @@ -5,8 +5,9 @@ Authors: Kim Morrison, Eric Wieser -/ module -import all Init.Data.List.Sort.Basic +public import Cslib.Foundations.Control.Monad.IsMonadHom +import all Init.Data.List.Sort.Basic import Cslib.Init /-! @@ -18,9 +19,11 @@ algorithmic analysis. public section +open Cslib (IsMonadHom) + namespace List -variable {m} [Monad m] +variable {m n} [Monad m] [Monad n] /-- A monadic version of `List.merge` -/ def mergeM (xs ys : List α) (le : α → α → m Bool) : m (List α) := do @@ -33,9 +36,11 @@ def mergeM (xs ys : List α) (le : α → α → m Bool) : m (List α) := do else return y :: (← mergeM (x :: xs) ys le) -@[simp] theorem nil_mergeM (ys : List α) (le : α → α → m Bool) : mergeM [] ys le = pure ys := by +@[simp, grind =] +theorem nil_mergeM (ys : List α) (le : α → α → m Bool) : mergeM [] ys le = pure ys := by simp [mergeM] -@[simp] theorem mergeM_right (xs : List α) (le : α → α → m Bool) : mergeM xs [] le = pure xs := by +@[simp, grind =] +theorem mergeM_right (xs : List α) (le : α → α → m Bool) : mergeM xs [] le = pure xs := by induction xs with | nil => simp | cons x xs ih => simp [mergeM] @@ -57,6 +62,14 @@ theorem idRun_mergeM (xs ys : List α) (le : α → α → Id Bool) : Id.run (mergeM xs ys le) = merge xs ys (fun x y => Id.run <| le x y) := mergeM_pure _ _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_listMergeM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (xs ys : List α) (le : α → α → m Bool) : + f (mergeM xs ys le) = mergeM xs ys (fun x y => f (le x y)) := by + fun_induction mergeM xs ys le with + | case1 | case2 => grind + | case3 x xs y ys ihx ihy => simp [hf.map_bind, hf.map_pure, apply_ite f, ihx, ihy] + /-- A monadic version of `List.mergeSortM` -/ def mergeSortM (xs : List α) (le : α → α → m Bool) : m (List α) := match xs with @@ -88,4 +101,12 @@ theorem idRun_mergeSortM (xs : List α) (le : α → α → Id Bool) : Id.run (mergeSortM xs le) = mergeSort xs (fun x y => Id.run <| le x y) := mergeSortM_pure _ _ +@[grind .] +theorem _root_.Cslib.IsMonadHom.map_listMergeSortM {f : {β : Type} → m β → n β} + (hf : IsMonadHom m n f) (xs : List α) (le : α → α → m Bool) : + f (mergeSortM xs le) = mergeSortM xs (fun x y => f (le x y)) := by + fun_induction mergeSortM xs le with + | case1 | case2 => simp [hf.map_pure] + | case3 a b xs le ih1 ih2 => simp only [mergeSortM, hf.map_bind, ih1, ih2, hf.map_listMergeM, le] + end List diff --git a/Cslib/Algorithms/Lean/TimeM.lean b/Cslib/Algorithms/Lean/TimeM.lean index 389d6945b0..1cf75a4af4 100644 --- a/Cslib/Algorithms/Lean/TimeM.lean +++ b/Cslib/Algorithms/Lean/TimeM.lean @@ -7,6 +7,7 @@ Authors: Sorrachai Yingchareonthawornhcai, Eric Wieser module public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom public import Mathlib.Algebra.Group.Defs /-! @@ -97,6 +98,8 @@ instance [AddZero T] : Monad (TimeM T) where @[simp, grind =] theorem ret_bind {α β} [Add T] (m : TimeM T α) (f : α → TimeM T β) : (m >>= f).ret = (f m.ret).ret := rfl @[simp, grind =] theorem ret_map {α β} (f : α → β) (x : TimeM T α) : (f <$> x).ret = f x.ret := rfl +@[simp, grind =] theorem ret_mapConst {α β} (a : α) (x : TimeM T β) : + (Functor.mapConst a x).ret = a := rfl @[simp] theorem ret_seqRight {α} (x : TimeM T α) (y : Unit → TimeM T β) [Add T] : (SeqRight.seqRight x y).ret = (y ()).ret := rfl @[simp] theorem ret_seqLeft {α} [Add T] (x : TimeM T α) (y : Unit → TimeM T β) : @@ -104,6 +107,15 @@ instance [AddZero T] : Monad (TimeM T) where @[simp] theorem ret_seq {α β} [Add T] (f : TimeM T (α → β)) (x : Unit → TimeM T α) : (Seq.seq f x).ret = f.ret (x ()).ret := rfl +theorem isMonadHom_pure_ret [AddZero T] : Cslib.IsMonadHom (TimeM T) Id (fun x => pure x.ret) where + map_map _ _ := Id.ext <| ret_map _ _ + map_mapConst _ __ := Id.ext <| ret_mapConst _ _ + map_pure _ := Id.ext <| ret_pure _ + map_seq _ _ := Id.ext <| ret_seq _ _ + map_seqLeft _ _ := Id.ext <| ret_seqLeft _ _ + map_seqRight _ _ := Id.ext <| ret_seqRight _ _ + map_bind _ _ := Id.ext <| ret_bind _ _ + @[simp, grind =] theorem time_bind {α β} [Add T] (m : TimeM T α) (f : α → TimeM T β) : (m >>= f).time = m.time + (f m.ret).time := rfl @[simp, grind =] theorem time_pure {α} [Zero T] (a : α) : (pure a : TimeM T α).time = 0 := rfl diff --git a/Cslib/Computability/Automata/DA/Congr.lean b/Cslib/Computability/Automata/DA/Congr.lean index d4c4356373..25937ab90d 100644 --- a/Cslib/Computability/Automata/DA/Congr.lean +++ b/Cslib/Computability/Automata/DA/Congr.lean @@ -7,17 +7,17 @@ Authors: Ching-Tsun Chou module public import Cslib.Computability.Automata.DA.Basic -public import Cslib.Computability.Languages.Congruences.RightCongruence +public import Cslib.Computability.Languages.Congruences.Basic /-! # Deterministic automaton corresponding to a right congruence. -/ @[expose] public section -namespace Cslib +variable {Symbol : Type*} -open scoped FLTS RightCongruence +namespace Language -variable {Symbol : Type*} +open Cslib /-- Every right congruence gives rise to a DA whose states are the equivalence classes of the right congruence, whose start state is the empty word, and whose transition functiuon @@ -28,11 +28,16 @@ def RightCongruence.toDA [c : RightCongruence Symbol] : Automata.DA (Quotient c. tr s x := Quotient.lift (fun u ↦ ⟦ u ++ [x] ⟧) (by intro u v h_eq apply Quotient.sound - exact right_cov.elim [x] h_eq + exact c.right_cov.elim [x] h_eq ) s start := ⟦ [] ⟧ -namespace Automata.DA +end Language + +namespace Cslib.Automata.DA + +open Language +open scoped FLTS RightCongruence variable [c : RightCongruence Symbol] @@ -49,6 +54,14 @@ theorem congr_mtr_eq {xs : List Symbol} : specialize h_ind (xs := ys.reverse) (by grind) grind [Quotient.lift_mk] +/-- After consuming a finite word `ys` from the state `⟦ xs ⟧`, `c.toDA` reaches +the state `⟦ xs ++ ys ⟧`. -/ +@[simp, scoped grind =] +theorem congr_mtr_append {xs ys : List Symbol} : + c.toDA.mtr ⟦ xs ⟧ ys = ⟦ xs ++ ys ⟧ := by + nth_rewrite 1 [← congr_mtr_eq, ← FLTS.mtr_append_eq] + rw [congr_mtr_eq] + namespace FinAcc open Acceptor RightCongruence @@ -66,6 +79,4 @@ theorem congr_language_eq {a : Quotient c.eq} : language (FinAcc.mk c.toDA {a}) end FinAcc -end Automata.DA - -end Cslib +end Cslib.Automata.DA diff --git a/Cslib/Computability/Automata/TwoWayNA/Basic.lean b/Cslib/Computability/Automata/TwoWayNA/Basic.lean index 4741a0c3fc..edd70a1195 100644 --- a/Cslib/Computability/Automata/TwoWayNA/Basic.lean +++ b/Cslib/Computability/Automata/TwoWayNA/Basic.lean @@ -27,7 +27,8 @@ ends in an accepting state with the head just past the end of the input. * `TwoWayNA`, the automaton itself * `TwoWayNACfg`, a configuration of a `TwoWayNA`: Its input plus a state and the head position. -* `TwoWayNA.Step`, The single-step relation between configurations. +* `TwoWayNA.toCfgNA`, the finite acceptor on configurations whose runs on a fixed input are + the runs of the two-way automaton on that input. It also provides the `Acceptor` instance. ## Implementation notes @@ -84,7 +85,7 @@ def TwoWayNACfg.IsAccepting (a : TwoWayNA State Symbol) (c : TwoWayNACfg State S /-- Returns a nondeterministic finite acceptor on the configurations as states, accepting exactly the runs of the two-way automaton on `input` that end in an accepting configuration. -/ -def TwoWayNA.toCfgNAFinAcc {State Symbol : Type*} (a : TwoWayNA State Symbol) +def TwoWayNA.toCfgNA {State Symbol : Type*} (a : TwoWayNA State Symbol) (input : List Symbol) : NA.FinAcc (TwoWayNACfg State Symbol) (Symbol × SignType) where Tr @@ -101,16 +102,33 @@ def TwoWayNA.toCfgNAFinAcc {State Symbol : Type*} (a : TwoWayNA State Symbol) start := { c | c.IsInitialForInput a input } accept := { c | c.IsAccepting a } -/-- Any reachable state of `a.toCfgNAFinAcc input` contains the original input. -/ -lemma TwoWayNA.toCfgNAFinAcc_input_eq {State Symbol : Type*} (a : TwoWayNA State Symbol) - (input : List Symbol) : - (a.toCfgNAFinAcc input).toLTS.TrInv (fun c => c.input = input) := by - intro c μ c' h_tr rfl - simp_all [TwoWayNA.toCfgNAFinAcc] - @[simp, scoped grind =] instance : Acceptor (TwoWayNA State Symbol) Symbol where Accepts (a : TwoWayNA State Symbol) (input : List Symbol) := - ∃ μs, Acceptor.Accepts (a.toCfgNAFinAcc input) μs + ∃ μs, Acceptor.Accepts (a.toCfgNA input) μs + +/-- Any reachable state of `a.toCfgNA input` contains the original input. -/ +lemma TwoWayNA.toCfgNA_input_eq {State Symbol : Type*} (a : TwoWayNA State Symbol) + (input : List Symbol) : + (a.toCfgNA input).TrInv (fun c => c.input = input) := by + intro c μ c' h_tr rfl + simp_all [TwoWayNA.toCfgNA] + +/-- A configuration running on `input` is the one determined by its state and head position. -/ +theorem TwoWayNACfg.eta {input : List Symbol} {c : TwoWayNACfg State Symbol} + (h : c.input = input) (h' : (c.pos : ℕ) < input.length + 1) : + ({ input := input, pos := ⟨c.pos, h'⟩, state := c.state } : TwoWayNACfg State Symbol) = c := by + cases c + subst h + rfl + +/-- A step reads the symbol at the head position, which therefore lies inside the input. -/ +theorem TwoWayNA.getElem_of_tr {a : TwoWayNA State Symbol} {input : List Symbol} + {c c' : TwoWayNACfg State Symbol} {x : Symbol} {m : SignType} + (htr : (a.toCfgNA input).Tr c (x, m) c') (hc : c.input = input) : + ∃ h : (c.pos : ℕ) < input.length, input[(c.pos : ℕ)] = x := by + obtain ⟨-, hx, -, -⟩ := htr + subst hc + exact List.getElem?_eq_some_iff.mp hx.symm end Cslib.Automata diff --git a/Cslib/Computability/Automata/TwoWayNA/ComplToNA.lean b/Cslib/Computability/Automata/TwoWayNA/ComplToNA.lean new file mode 100644 index 0000000000..ae29323509 --- /dev/null +++ b/Cslib/Computability/Automata/TwoWayNA/ComplToNA.lean @@ -0,0 +1,285 @@ +/- +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.Automata.NA.Basic +public import Cslib.Computability.Automata.TwoWayNA.Basic +public import Cslib.Foundations.Data.OmegaSequence.Init +public import Cslib.Foundations.Semantics.LTS.Relation + +/-! # A finite acceptor for the complement of the language of a two-way automaton + +For every nondeterministic two-way automaton (`TwoWayNA`) `a`, this file constructs a +nondeterministic finite acceptor (`NA.FinAcc`) that accepts exactly the words rejected by `a` +(`TwoWayNA.complToNA`, `TwoWayNA.language_complToNA`). We follow Vardi's proof, which -- +unlike Shepherdson's crossing-sequence argument -- characterises non-acceptance in a way that can +be checked by a single left-to-right sweep over the input. + +This result is the main ingredient in proving equivalence of two-way and one-way automata, which +can be found in `Cslib.Computability.Languages.RegularLanguages`. + +## Vardi's condition of non-acceptance + +Fix a `TwoWayNA` `a` and an input word `input` of length `n`. A *rejection certificate* is a family +of subsets `cert i ⊆ State`, one for every head position `i ∈ {0, …, n}`, subject to three +conditions: + +1. `cert` contains every initial state at position `0` (`IsRejectionCert.start_mem`); +2. `cert` is an invariant of the transitions of `a`: if the state `c.state` is in `cert c.pos` and + `a` can step from the configuration `c` to the configuration `c'`, then `c'.state` is in + `cert c'.pos` (`TwoWayNA.IsStepClosed`, `IsRejectionCert.step_closed`); +3. no state in `cert n`, i.e. at the position just past the end of the input, is accepting + (`IsRejectionCert.accept_notMem`). + +Intuitively, `cert i` over-approximates the set of states in which `a` can be while its head sits at +position `i`: conditions 1 and 2 make `cert` an inductive invariant of the reachable configurations, +and condition 3 says that this invariant rules out acceptance -- being preserved by every step, it +holds at the end of every run (`LTS.mtrInv_of_trInv`). Conversely, the reachable states +(`TwoWayNA.reachable`) themselves form the least such family, so a certificate exists exactly when +`a` rejects (`TwoWayNA.not_accepts_iff_exists_isRejectionCert`). + +## The finite acceptor for the complement + +The point of the reformulation is locality: `TwoWayNA.isStepClosed_iff_localOK` turns condition 2 +into a condition `TwoWayNA.LocalOK` relating only `cert (i - 1)`, `cert i` and `cert (i + 1)` with +the symbol at position `i`. A finite acceptor can therefore guess the certificate while scanning the +input, keeping only the last two subsets in its state. This is `TwoWayNA.complToNA`, and +`TwoWayNA.accepts_complToNA_iff` shows that it accepts exactly the words rejected by `a`. + +## Implementation notes + +A rejection certificate is an `ωSequence`, i.e. indexed by `ℕ` rather than by +`Fin (input.length + 1)`, the type of `TwoWayNACfg.pos`: positions past the end of the input are +simply left unconstrained, which avoids casts when the certificate is compared along a run, whose +configurations carry their own input. The subset for the missing position to the left of the input +is supplied by prepending `Set.univ` with `ωSequence.cons`. + +`TwoWayNA.exists_accepting_mTr_iff` is proved by induction on the input word, prepending a subset +to the certificate at each step with `ωSequence.cons` and dropping one with `ωSequence.tail`. + +## References + +* [M. Y. Vardi, *A note on the reduction of two-way automata to one-way automata*][Vardi1989] +-/ + +@[expose] public section + +namespace Cslib.Automata + +open scoped ωSequence +open Acceptor + +variable {State Symbol : Type*} {a : TwoWayNA State Symbol} {input : List Symbol} + +namespace TwoWayNA + +/-! ## Vardi's condition of non-acceptance -/ + +/-- Every step of `a` on `input` out of a state that `cert` attaches to the head position lands in a +state that `cert` attaches to the new head position. The conjunct on the input restricts the +invariant to the configurations that run on `input`. -/ +def IsStepClosed (a : TwoWayNA State Symbol) (input : List Symbol) + (cert : ωSequence (Set State)) : Prop := + (a.toCfgNA input).TrInv (fun c => c.input = input ∧ c.state ∈ cert c.pos) + +/-- A family of subsets of the state set, one for every position of the input head on `input`, +which contains all initial states, is closed under the transitions of `a`, and contains no +accepting state at the position just past the end of the input. -/ +structure IsRejectionCert (a : TwoWayNA State Symbol) (input : List Symbol) + (cert : ωSequence (Set State)) : Prop where + /-- Every initial state occurs at the initial head position. -/ + start_mem : ∀ s ∈ a.start, s ∈ cert 0 + /-- The family is an invariant of the transitions of `a`. -/ + step_closed : a.IsStepClosed input cert + /-- No accepting state occurs past the end of the input. -/ + accept_notMem : ∀ s ∈ cert input.length, s ∉ a.accept + +variable {cert : ωSequence (Set State)} + +/-- If a rejection certificate for `input` exists, then `a` does not accept `input`. -/ +theorem IsRejectionCert.not_accepts (hT : a.IsRejectionCert input cert) : + ¬ Accepts a input := by + rintro ⟨μs, c, ⟨hstart, hpos, hinput⟩, c', ⟨hacc, hlast⟩, hmtr⟩ + obtain ⟨hinput', hmem⟩ := LTS.mtrInv_of_trInv hT.step_closed c μs c' hmtr + ⟨hinput, by simpa [hpos] using hT.start_mem c.state hstart⟩ + rw [hlast, Fin.val_last, hinput'] at hmem + exact hT.accept_notMem c'.state hmem hacc + +/-- The set of states that `a` can be in while its head sits at position `i` of `input`, having +started in an initial configuration. -/ +def reachable (a : TwoWayNA State Symbol) (input : List Symbol) : ωSequence (Set State) := + fun i => {q | ∃ c, c.IsInitialForInput a input ∧ + ∃ h : i < input.length + 1, + (a.toCfgNA input).CanReach c { input := input, pos := ⟨i, h⟩, state := q } } + +/-- If `a` does not accept `input`, then its reachable states form a rejection certificate. -/ +theorem isRejectionCert_reachable (h : ¬ Accepts a input) : + a.IsRejectionCert input (a.reachable input) where + start_mem s hs := + ⟨{ input := input, pos := ⟨0, Nat.succ_pos _⟩, state := s }, + ⟨hs, Fin.ext (by simp), rfl⟩, Nat.succ_pos _, LTS.CanReach.refl _ _⟩ + step_closed c μ c' htr := by + rintro ⟨hc_input, c₀, hstart, hlt, hreach⟩ + have hc'_input : c'.input = input := a.toCfgNA_input_eq input c μ c' htr hc_input + rw [TwoWayNACfg.eta hc_input hlt] at hreach + refine ⟨hc'_input, c₀, hstart, hc'_input ▸ c'.pos.isLt, ?_⟩ + rw [TwoWayNACfg.eta hc'_input] + exact (LTS.reflTransGen_unlabelledTr_iff _).mp + (((LTS.reflTransGen_unlabelledTr_iff _).mpr hreach).tail ⟨μ, htr⟩) + accept_notMem s hs hacc := by + obtain ⟨c₀, hstart, hlt, μs, hmtr⟩ := hs + exact h ⟨μs, c₀, hstart, _, ⟨hacc, Fin.ext (by simp)⟩, hmtr⟩ + +/-- A two-way automaton rejects an input exactly when a rejection certificate for it exists. -/ +theorem not_accepts_iff_exists_isRejectionCert (a : TwoWayNA State Symbol) + (input : List Symbol) : + ¬ Accepts a input ↔ ∃ T, a.IsRejectionCert input T := + ⟨fun h => ⟨_, isRejectionCert_reachable h⟩, by rintro ⟨_, hT⟩; exact hT.not_accepts⟩ + +/-! ## Localising the closure condition -/ + +/-- Every move of `a` out of a state in `cur` while reading `x` lands in `left`, in `cur` or in +`right`, according to whether it moves the head to the left, keeps it in place, or moves it to the +right. -/ +def LocalOK (a : TwoWayNA State Symbol) (x : Symbol) (left cur right : Set State) : Prop := + ∀ q ∈ cur, ∀ m q', a.Tr q x m q' → + q' ∈ match m with | .neg => left | .zero => cur | .pos => right + +/-- Closure of `cert` under the transitions of `a` is the same as local consistency of `cert` at +every position carrying an input symbol. -/ +theorem isStepClosed_iff_localOK : + a.IsStepClosed input cert ↔ + ∀ i : Fin input.length, + a.LocalOK input[i] ((Set.univ ::ω cert) i) (cert i) (cert (i + 1)) := by + constructor + · intro hcl i q hq m q' htr + have hlt : (i : ℕ) < input.length := i.isLt + cases m with + | zero => + exact (hcl ⟨input, q, ⟨i, by omega⟩⟩ (input[i], SignType.zero) + ⟨input, q', ⟨i, by omega⟩⟩ ⟨rfl, by simp, htr, by simp⟩ ⟨rfl, hq⟩).2 + | pos => + exact (hcl ⟨input, q, ⟨i, by omega⟩⟩ (input[i], SignType.pos) + ⟨input, q', ⟨i + 1, by omega⟩⟩ ⟨rfl, by simp, htr, by simp⟩ ⟨rfl, hq⟩).2 + | neg => + obtain ⟨iv, hiv⟩ := i + obtain _ | j := iv + · exact Set.mem_univ q' + · exact (hcl ⟨input, q, ⟨j + 1, by omega⟩⟩ (input[j + 1], SignType.neg) + ⟨input, q', ⟨j, by omega⟩⟩ ⟨rfl, by simp, htr, by simp⟩ ⟨rfl, hq⟩).2 + · rintro hloc c ⟨x, m⟩ c' hstep ⟨hc_input, hmem⟩ + refine ⟨a.toCfgNA_input_eq input c (x, m) c' hstep hc_input, ?_⟩ + obtain ⟨hlt, rfl⟩ := getElem_of_tr hstep hc_input + obtain ⟨-, -, htr, hpos⟩ := hstep + have hthis := hloc ⟨(c.pos : ℕ), hlt⟩ c.state hmem m c'.state htr + cases m with + | zero => + have hpos' : (c'.pos : ℕ) = (c.pos : ℕ) := by simp at hpos; omega + rwa [hpos'] + | pos => + have hpos' : (c'.pos : ℕ) = (c.pos : ℕ) + 1 := by simp at hpos; omega + rwa [hpos'] + | neg => + simp only [SignType.neg_eq_neg_one, SignType.coe_neg_one] at hpos + obtain ⟨j, hj⟩ : ∃ j, (c.pos : ℕ) = j + 1 := ⟨(c.pos : ℕ) - 1, by omega⟩ + have hpos' : (c'.pos : ℕ) = j := by omega + rw [hpos'] + rwa [show ((⟨(c.pos : ℕ), hlt⟩ : Fin input.length) : ℕ) = j + 1 from hj] at hthis + +/-! ## The finite acceptor for the complement -/ + +/-- The nondeterministic finite acceptor that guesses a rejection certificate `cert` for `a` while +scanning the input, keeping the pair `(cert (i - 1), cert i)` in its state after reading `i` +symbols. +Reading the symbol at position `i` guesses `cert (i + 1)` and checks local consistency at `i`. -/ +def complToNA (a : TwoWayNA State Symbol) : NA.FinAcc (Set State × Set State) Symbol where + Tr + | (prev, cur), x, (prev', cur') => prev' = cur ∧ a.LocalOK x prev cur cur' + start := {(prev, cur) | prev = Set.univ ∧ a.start ⊆ cur} + accept := {(_, cur) | ∀ s ∈ cur, s ∉ a.accept} + +/-- An accepting multistep transition of `a.complToNA` out of `(left, cur)` over `xs` is the same +thing as a certificate starting with `left` and `cur` that is locally consistent at every position +of `xs` and has no accepting state at the position just past `xs`. -/ +theorem exists_accepting_mTr_iff (a : TwoWayNA State Symbol) (xs : List Symbol) + (left cur : Set State) : + (∃ f ∈ a.complToNA.accept, a.complToNA.MTr (left, cur) xs f) ↔ + ∃ cert : ωSequence (Set State), cert 0 = left ∧ cert 1 = cur ∧ + (∀ i, ∀ hi : i < xs.length, a.LocalOK xs[i] (cert i) (cert (i + 1)) (cert (i + 2))) ∧ + ∀ s ∈ cert (xs.length + 1), s ∉ a.accept := by + induction xs generalizing left cur with + | nil => + constructor + · rintro ⟨f, hf, hmtr⟩ + rw [LTS.MTr.nil_iff] at hmtr + subst hmtr + exact ⟨left ::ω ωSequence.const cur, rfl, rfl, by simp, by simpa [complToNA] using hf⟩ + · rintro ⟨cert, h0, h1, -, hacc⟩ + exact ⟨(left, cur), by simpa [complToNA, ← h1] using hacc, by simp⟩ + | cons x xs ih => + constructor + · rintro ⟨f, hf, hmtr⟩ + rw [LTS.MTr.cons_iff] at hmtr + obtain ⟨⟨m₁, m₂⟩, ⟨rfl, hlocal⟩, hmtr⟩ := hmtr + obtain ⟨cert, h0, h1, hloc, hacc⟩ := (ih m₁ m₂).mp ⟨f, hf, hmtr⟩ + have hstep : ∀ i, ∀ hi : i < (x :: xs).length, a.LocalOK (x :: xs)[i] + ((left ::ω cert) i) ((left ::ω cert) (i + 1)) ((left ::ω cert) (i + 2)) := by + intro i hi + obtain _ | i := i + · simpa [h0, h1] using hlocal + · simpa using hloc i (by simpa using hi) + exact ⟨left ::ω cert, rfl, by simpa using h0, hstep, by simpa using hacc⟩ + · rintro ⟨cert, h0, h1, hloc, hacc⟩ + have hstep : ∀ i, ∀ hi : i < xs.length, + a.LocalOK xs[i] (cert.tail i) (cert.tail (i + 1)) (cert.tail (i + 2)) := by + intro i hi + have h := hloc (i + 1) (by simpa using hi) + rw [List.getElem_cons_succ] at h + simpa [ωSequence.get_tail, Nat.add_right_comm] using h + obtain ⟨f, hf, hmtr⟩ := (ih cur (cert 2)).mpr + ⟨cert.tail, by simpa using h1, by simp [ωSequence.get_tail], hstep, by simpa using hacc⟩ + have hlocal : a.LocalOK x left cur (cert 2) := by + have h := hloc 0 (by simp) + rw [List.getElem_cons_zero] at h + simpa [h0, h1] using h + exact ⟨f, hf, LTS.MTr.cons_iff.mpr ⟨(cur, cert 2), ⟨rfl, hlocal⟩, hmtr⟩⟩ + +/-- `a.complToNA` accepts exactly the words that `a` rejects. -/ +theorem accepts_complToNA_iff (a : TwoWayNA State Symbol) (input : List Symbol) : + Accepts a.complToNA input ↔ ¬ Accepts a input := by + rw [not_accepts_iff_exists_isRejectionCert] + constructor + · rintro ⟨s, ⟨hs, hstart⟩, f, hf, hmtr⟩ + obtain ⟨cert, h0, h1, hloc, hacc⟩ := (exists_accepting_mTr_iff a input s.1 s.2).mp ⟨f, hf, hmtr⟩ + have hcert : Set.univ ::ω cert.tail = cert := by + rw [← hs, ← h0] + exact ωSequence.eta cert + have hstep : ∀ i : Fin input.length, + a.LocalOK input[i] ((Set.univ ::ω cert.tail) i) (cert.tail i) (cert.tail (i + 1)) := + fun i => by simpa [hcert, ωSequence.get_tail] using hloc i i.isLt + exact ⟨cert.tail, + { start_mem := by + intro q hq + simpa [h1] using hstart hq + step_closed := isStepClosed_iff_localOK.mpr hstep + accept_notMem := by simpa using hacc }⟩ + · rintro ⟨cert, hCert⟩ + have hloc := isStepClosed_iff_localOK.mp hCert.step_closed + obtain ⟨f, hf, hmtr⟩ := (exists_accepting_mTr_iff a input Set.univ (cert 0)).mpr + ⟨Set.univ ::ω cert, rfl, rfl, fun i hi => by simpa using hloc ⟨i, hi⟩, + by simpa using hCert.accept_notMem⟩ + exact ⟨(Set.univ, cert 0), ⟨rfl, hCert.start_mem⟩, f, hf, hmtr⟩ + +/-- `a.complToNA` recognises the complement of the language of `a`. -/ +theorem language_complToNA (a : TwoWayNA State Symbol) : language a.complToNA = (language a)ᶜ := by + ext xs + simp only [Acceptor.mem_language] + exact accepts_complToNA_iff a xs + +end TwoWayNA + +end Cslib.Automata diff --git a/Cslib/Computability/Automata/TwoWayNA/OfNA.lean b/Cslib/Computability/Automata/TwoWayNA/OfNA.lean new file mode 100644 index 0000000000..5a556b013d --- /dev/null +++ b/Cslib/Computability/Automata/TwoWayNA/OfNA.lean @@ -0,0 +1,106 @@ +/- +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.Automata.TwoWayNA.Basic + +/-! # Finite acceptors as two-way automata + +A nondeterministic finite acceptor (`NA.FinAcc`) is the special case of a nondeterministic two-way +automaton (`TwoWayNA`) that moves its head one symbol to the right in every step, +`NA.FinAcc.toTwoWayNA`. + +The head of `a.toTwoWayNA` is thus at position `i` exactly when `a` has read the first `i` +symbols of the input, so the runs of the two-way automaton are in lockstep with the multistep +transitions of `a` (`TwoWayNA.mTr_take_of_mTr_toCfgNA`, `TwoWayNA.mTr_toCfgNA_of_mTr`) and the two +accept the same words (`TwoWayNA.accepts_toTwoWayNA_iff`, `TwoWayNA.language_toTwoWayNA`). +-/ + +@[expose] public section + +namespace Cslib.Automata + +variable {State Symbol : Type*} {input : List Symbol} + +/-- The two-way automaton that performs the transitions of the nondeterministic finite acceptor +`n`, always moving its head one symbol to the right. -/ +def NA.FinAcc.toTwoWayNA (n : NA.FinAcc State Symbol) : TwoWayNA State Symbol where + Tr q x m q' := m = SignType.pos ∧ n.Tr q x q' + start := n.start + accept := n.accept + +namespace TwoWayNA + +variable {a : NA.FinAcc State Symbol} + +/-- A run of `a.toTwoWayNA` that starts in an initial configuration reads a multistep transition +of `a` over the prefix of `input` that its head has scanned. -/ +theorem mTr_take_of_mTr_toCfgNA {c c' : TwoWayNACfg State Symbol} + {μs : List (Symbol × SignType)} + (hstart : c ∈ (a.toTwoWayNA.toCfgNA input).start) + (hrun : (a.toTwoWayNA.toCfgNA input).MTr c μs c') : + a.MTr c.state (input.take c'.pos) c'.state := by + obtain ⟨-, hpos, rfl⟩ := hstart + refine (LTS.mtrInv_of_trInv + (p := fun d => d.input = c.input ∧ a.MTr c.state (c.input.take d.pos) d.state) ?_ c μs c' hrun + ⟨rfl, by simp [hpos]⟩).2 + rintro d ⟨x, m⟩ d' hstep ⟨hd, hmtr⟩ + obtain ⟨hlt, rfl⟩ := getElem_of_tr (input := c.input) hstep hd + obtain ⟨hinput, -, ⟨rfl, htr⟩, hpos⟩ := hstep + have hpos' : (d'.pos : ℕ) = (d.pos : ℕ) + 1 := by simp at hpos; omega + refine ⟨hinput ▸ hd, ?_⟩ + rw [hpos', List.take_succ_eq_append_getElem hlt] + exact LTS.MTr.stepR _ hmtr htr + +/-- A multistep transition of `a` over a prefix of `input` is read by the run of `a.toTwoWayNA` +that takes its head from the beginning of the input to the end of that prefix, moving one symbol +to the right in every step. -/ +theorem mTr_toCfgNA_of_mTr {s s' : State} {pre : List Symbol} (hpre : pre <+: input) + (hmtr : a.MTr s pre s') : + (a.toTwoWayNA.toCfgNA input).MTr ⟨input, s, 0⟩ (pre.map (·, SignType.pos)) + ⟨input, s', ⟨pre.length, by grind⟩⟩ := by + induction pre using List.reverseRecOn generalizing s' with + | nil => simp_all + | append_singleton pre x ih => + rw [LTS.MTr.append_iff] at hmtr + obtain ⟨t, hmtr, htr⟩ := hmtr + rw [LTS.MTr.singleton_iff] at htr + have hlt : pre.length < input.length := by grind + have hx : input[pre.length] = x := by + rw [← hpre.getElem (by simp)] + simp + have hstep : (a.toTwoWayNA.toCfgNA input).Tr + ⟨input, t, ⟨pre.length, by omega⟩⟩ (x, SignType.pos) + ⟨input, s', ⟨(pre ++ [x]).length, by simpa using hlt⟩⟩ := + ⟨rfl, by simp [← hx], ⟨rfl, htr⟩, by simp⟩ + rw [List.map_append] + exact LTS.MTr.stepR _ (ih ((List.prefix_append _ _).trans hpre) hmtr) hstep + +open Acceptor + +/-- A nondeterministic finite acceptor and its two-way rendering accept the same words. -/ +theorem accepts_toTwoWayNA_iff (a : NA.FinAcc State Symbol) (input : List Symbol) : + Accepts a.toTwoWayNA input ↔ Accepts a input := by + constructor + · rintro ⟨μs, c, ⟨hs, hpos, hinput⟩, c', ⟨hacc, hlast⟩, hmtr⟩ + subst hinput + have hinput' := LTS.mtrInv_of_trInv (toCfgNA_input_eq _ _) c μs c' hmtr rfl + have hmtr := mTr_take_of_mTr_toCfgNA ⟨hs, hpos, rfl⟩ hmtr + rw [hlast, Fin.val_last, hinput', List.take_length] at hmtr + exact ⟨c.state, hs, c'.state, hacc, hmtr⟩ + · rintro ⟨s, hs, s', hs', hmtr⟩ + exact ⟨_, ⟨input, s, 0⟩, ⟨hs, rfl, rfl⟩, ⟨input, s', Fin.last _⟩, ⟨hs', rfl⟩, + mTr_toCfgNA_of_mTr (List.prefix_refl _) hmtr⟩ + +/-- A nondeterministic finite acceptor and its two-way rendering recognise the same language. -/ +theorem language_toTwoWayNA (a : NA.FinAcc State Symbol) : language a.toTwoWayNA = language a := by + ext xs + simpa [Acceptor.mem_language] using accepts_toTwoWayNA_iff a xs + +end TwoWayNA + +end Cslib.Automata diff --git a/Cslib/Computability/Circuit/Basic.lean b/Cslib/Computability/Circuit/Basic.lean index c3d1508bde..2f003728d5 100644 --- a/Cslib/Computability/Circuit/Basic.lean +++ b/Cslib/Computability/Circuit/Basic.lean @@ -16,9 +16,6 @@ an output is free: projections and duplicated outputs cost no gates. The size of a circuit is its gate count and its depth is the maximum depth of a designated output wire. -A dependent pair `Σ gateCount, Circuit σ inputCount gateCount outputCount` -hides the gate count for constructions that compute it along the way. - For the standard Boolean circuit model, see [Arora and Barak, Section 6.1][AroraBarak09]. Here a topological ordering is part of the representation, and the Boolean gate basis is generalized to an arbitrary `Signature` and `Interpretation`. Our size @@ -53,6 +50,15 @@ structure Circuit (σ : Signature) (inputCount gateCount outputCount : Nat) wher /-- The input or internal-gate wire carrying each output. -/ outputs : Fin outputCount → Wire inputCount gateCount +/-- A circuit consists of its program and its tuple of output wires. -/ +def Circuit.equiv (σ : Signature) (inputCount gateCount outputCount : Nat) : + Circuit σ inputCount gateCount outputCount ≃ + Program σ inputCount gateCount × (Fin outputCount → Wire inputCount gateCount) where + toFun c := (c.program, c.outputs) + invFun c := ⟨c.1, c.2⟩ + left_inv _ := rfl + right_inv _ := rfl + /-- The zero-gate identity circuit, whose outputs are its inputs. -/ def Circuit.id (σ : Signature) (inputCount : Nat) : Circuit σ inputCount 0 inputCount where program := .empty @@ -87,6 +93,11 @@ def Circuit.eval (x : Fin inputCount → U) : Fin outputCount → U := c.program.trace i x ∘ c.outputs +/-- A single-output circuit computes `f` when its output agrees with `f` on every input. -/ +def Circuit.Computes (c : Circuit σ inputCount gateCount 1) + (interpretation : Interpretation σ U) (f : (Fin inputCount → U) → U) : Prop := + ∀ x, c.eval interpretation x 0 = f x + @[simp] theorem Circuit.eval_id (interpretation : Interpretation σ U) (input : Fin inputCount → U) : diff --git a/Cslib/Computability/Circuit/Boolean/Basic.lean b/Cslib/Computability/Circuit/Boolean/Basic.lean new file mode 100644 index 0000000000..722f0d8ab4 --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Basic.lean @@ -0,0 +1,74 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic +public import Mathlib.Data.Fintype.Card +public import Mathlib.Data.Fintype.Sum +public import Mathlib.Tactic.DeriveFintype + +/-! +# Boolean circuits + +The De Morgan basis consists of binary AND and OR, unary NOT, and Boolean constants. +Every gate has fan-in at most two, so these are the usual bounded fan-in Boolean circuits +(`Program.fanInAtMost_two`). Circuit size counts every gate, including constants; +designated output wires are free. +-/ + +@[expose] public section + +namespace Cslib.Circuits +namespace Boolean + +/-- Boolean functions on `n` inputs. -/ +abbrev BooleanFunction (n : ℕ) := (Fin n → Bool) → Bool + +/-- Operations of the De Morgan basis, including constants. -/ +inductive Op where + /-- A Boolean constant. -/ + | const (value : Bool) + /-- Negation. -/ + | not + /-- Binary conjunction. -/ + | and + /-- Binary disjunction. -/ + | or + deriving DecidableEq, Fintype + +/-- The De Morgan basis has five operation symbols, counting its two constants. -/ +@[simp] theorem Op.card : Fintype.card Op = 5 := rfl + +/-- The De Morgan signature. -/ +abbrev signature : Signature where + Op := Op + Arity + | .const _ => 0 + | .not => 1 + | .and | .or => 2 + +/-- The usual Boolean interpretation. -/ +def interpretation : Interpretation signature Bool + | .const b, _ => b + | .not, x => !x 0 + | .and, x => x 0 && x 1 + | .or, x => x 0 || x 1 + +end Boolean + +/-- Every De Morgan program has fan-in at most two. -/ +theorem Program.fanInAtMost_two {n g : ℕ} (p : Program Boolean.signature n g) : + p.FanInAtMost 2 := by + induction p with + | empty => trivial + | gate p line ih => exact And.intro ih (by cases line.op <;> simp) + +/-- Every De Morgan circuit has fan-in at most two. -/ +theorem Circuit.fanInAtMost_two {n g o : ℕ} (c : Circuit Boolean.signature n g o) : + c.FanInAtMost 2 := + c.program.fanInAtMost_two + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Boolean/Counting.lean b/Cslib/Computability/Circuit/Boolean/Counting.lean new file mode 100644 index 0000000000..ce965ee837 --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Counting.lean @@ -0,0 +1,47 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Counting + +import Mathlib.Tactic.Linarith + +/-! +# Counting De Morgan circuits + +This file specializes the generic circuit counting bound to the five De Morgan operations, +all of arity at most two. The resulting factorial correction is used in Shannon's lower bound. +-/ + +@[expose] public section + +namespace Cslib.Circuits.Boolean + +variable {n s : ℕ} + +/-- Boolean functions on `n` inputs computable with at most `s` De Morgan gates. -/ +noncomputable abbrev computableFunctions (n s : ℕ) : Finset (BooleanFunction n) := + Circuits.computableFunctions interpretation n s + +theorem mem_computableFunctions {f : BooleanFunction n} : + f ∈ computableFunctions n s ↔ ∃ g ≤ s, ∃ c : Circuit signature n g 1, + c.Computes interpretation f := + Circuits.mem_computableFunctions + +/-- The De Morgan counting bound, accounting for gate relabelings. -/ +theorem card_computableFunctions_mul_factorial_le (n s : ℕ) : + (computableFunctions n s).card * s.factorial ≤ + (s + 1) * (5 * (n + s + 1) ^ 2) ^ s * (n + s) := by + apply Circuits.card_computableFunctions_mul_factorial_le interpretation n s + · nlinarith [Nat.le_mul_self (n + s + 1)] + · intro g hg + have h := Line.card_le (σ := signature) n g 2 (fun op => by cases op <;> simp) + simp only [Op.card] at h + exact h.trans (Nat.mul_le_mul_left 5 + (Nat.pow_le_pow_left (by omega : n + g + 1 ≤ n + s + 1) 2)) + +end Cslib.Circuits.Boolean diff --git a/Cslib/Computability/Circuit/Boolean/Lupanov.lean b/Cslib/Computability/Circuit/Boolean/Lupanov.lean new file mode 100644 index 0000000000..22da82262b --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Lupanov.lean @@ -0,0 +1,234 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.LupanovConstruction +public import Mathlib.Basic.Real.Basic +import Cslib.Foundations.Data.Nat.Asymptotics +import Mathlib.Algebra.Order.Archimedean.Real.Basic +import Mathlib.Order.Filter.AtTopBot.Basic +import Mathlib.Tactic.Linarith +import Mathlib.Tactic.Ring + +/-! +# Lupanov's asymptotically optimal upper bound + +Every Boolean function on `n` inputs has a De Morgan circuit with at most +`(1 + ε) * 2 ^ n / n` gates for all sufficiently large `n`, given any `ε > 0`. +The threshold is uniform in the function; size counts constants and negations. +This matches Shannon's counting lower bound up to the factor `1 + ε`, which is why the +bound is called asymptotically optimal. + +This file only does the asymptotics. The circuit comes from the block construction in +`LupanovConstruction.lean`, which gives, for any split of the inputs into `k` address bits +and `d` data bits and any positive block size `s`, a circuit with at most `bound k d s` gates. + +## Choosing the parameters + +Write `l = log₂ n`. We take `k = 3 l` address bits, `d = n - 3 l` data bits, and blocks of +`s = n - 5 l` rows. Then: + +* the leading term of `bound` is `(2 ^ k / s + 1) · 2 ^ d ≈ 2 ^ n / s`, and since + `s = n - 5 l` is `n (1 - o(1))`, this is `(1 + o(1)) 2 ^ n / n` (`mainTerm_le`); +* the minterms cost about `(2 ^ k + 2 ^ d) · 2 n = O(n ^ 4) + O(2 ^ n / n ^ 2)`, using + `2 ^ k ≤ n ^ 3`; +* the `left` parts cost about `(2 ^ k / s) · 2 ^ s · 2 s ≈ 2 ^ (k + s) = 2 ^ (n - 2 l)`, + which is `O(2 ^ n / n ^ 2)`. + +`bound_le` packages the two error terms as `3 n ^ 4 + 16 n · 2 ^ d`; +`Nat.eventually_mul_pow_le_pow` and `error_le` show that the polynomial and the exponential +term are each `o(2 ^ n / n)`. Then `eventually_bound_le` combines everything into +`P · n · bound ≤ (P + 1) · 2 ^ n` for all large `n`, for any natural number `P`. +Taking `P > 1 / ε` in `exists_circuit` gives the theorem. + +## References + +* [O. B. Lupanov, *On a Method of Circuit Synthesis*][Lupanov1958], + Theorem 4 and Section 6, pp. 131-135: the upper bound for general weighted bases, + specialized here to the De Morgan basis. +* [Stasys Jukna, *Boolean Function Complexity: Advances and Frontiers*][Jukna2012], + Theorem 1.15: a modern exposition. +-/ + +public section + +namespace Cslib.Circuits.Boolean.Lupanov + +open Filter + +/-- With the chosen parameters, the budget is the leading term `(2 ^ k / s + 1) · 2 ^ d` +plus error terms `3 n ^ 4`, from the address minterms, and `16 n · 2 ^ d`, from the data +minterms, the per-pattern overhead of every block (`left` parts, constants, conjunctions and +ORs), and the final constant. -/ +private theorem bound_le (n : ℕ) (hn : 5 * Nat.log2 n < n) : + bound (3 * Nat.log2 n) (n - 3 * Nat.log2 n) (n - 5 * Nat.log2 n) ≤ + (2 ^ (3 * Nat.log2 n) / (n - 5 * Nat.log2 n) + 1) * + 2 ^ (n - 3 * Nat.log2 n) + 3 * n ^ 4 + + 16 * n * 2 ^ (n - 3 * Nat.log2 n) := by + let l := Nat.log2 n + let k := 3 * l + let d := n - 3 * l + let s := n - 5 * l + let blockCount := 2 ^ k / s + 1 + have hl : 2 ^ l ≤ n := Nat.log2_self_le (by omega) + have hk : 2 ^ k ≤ n ^ 3 := by + calc + 2 ^ k = (2 ^ l) ^ 3 := by simp [k, pow_mul, Nat.mul_comm] + _ ≤ n ^ 3 := Nat.pow_le_pow_left hl _ + have hblocks : blockCount * s ≤ 2 ^ k + s := by + dsimp [blockCount] + nlinarith [Nat.div_mul_le_self (2 ^ k) s] + have hshift : 2 ^ k * 2 ^ s = 2 ^ l * 2 ^ d := by + rw [← pow_add, ← pow_add] + congr 1 + dsimp [k, s, d, l] + omega + have hbank : (2 ^ k + s) * 2 ^ s ≤ 2 * n * 2 ^ d := by + rw [Nat.add_mul, hshift] + have := Nat.mul_le_mul (by grind : s ≤ n) + (Nat.pow_le_pow_right (by omega : 1 ≤ 2) (by grind : s ≤ d)) + have := Nat.mul_le_mul_right (2 ^ d) hl + nlinarith + have hpattern : blockCount * (2 ^ s * (2 * s + 4)) ≤ 12 * n * 2 ^ d := by + calc + blockCount * (2 ^ s * (2 * s + 4)) ≤ blockCount * (2 ^ s * (6 * s)) := by + gcongr; grind + _ = 6 * (blockCount * s) * 2 ^ s := by ring + _ ≤ 6 * (2 ^ k + s) * 2 ^ s := by gcongr + _ ≤ 6 * (2 * n * 2 ^ d) := by nlinarith [hbank] + _ = 12 * n * 2 ^ d := by ring + have hmin : (2 ^ k + 2 ^ d) * (2 * n + 1) ≤ 3 * n ^ 4 + 3 * n * 2 ^ d := by + calc + (2 ^ k + 2 ^ d) * (2 * n + 1) ≤ (n ^ 3 + 2 ^ d) * (3 * n) := by gcongr; grind + _ = 3 * n ^ 4 + 3 * n * 2 ^ d := by ring + have hone : 1 ≤ n * 2 ^ d := Nat.mul_pos (by grind : 0 < n) (pow_pos (by omega) _) + change bound k d s ≤ blockCount * 2 ^ d + 3 * n ^ 4 + 16 * n * 2 ^ d + unfold bound + rw [show k + d = n by grind] + dsimp [blockCount] at hpattern ⊢ + nlinarith + +/-- For `P > 0`, the leading term is at most `(1 + 1 / P) · 2 ^ n / n` up to a lower-order +term, once `n` is large enough that dropping `5 log₂ n` rows per block costs at most a factor +`(P + 1) / P`. The statement is multiplied through by `P n` to stay in `ℕ`. -/ +private theorem mainTerm_le (P n : ℕ) + (hn : 5 * Nat.log2 n < n) (hP : (P + 1) * (5 * Nat.log2 n) ≤ n) : + P * n * ((2 ^ (3 * Nat.log2 n) / (n - 5 * Nat.log2 n) + 1) * + 2 ^ (n - 3 * Nat.log2 n)) ≤ (P + 1) * 2 ^ n + + (P + 1) * n * 2 ^ (n - 3 * Nat.log2 n) := by + let k := 3 * Nat.log2 n + let s := n - 5 * Nat.log2 n + let d := n - k + have hks : k + d = n := by dsimp [k, d]; omega + have hPs : P * n ≤ (P + 1) * s := by + dsimp [s] + have := Nat.sub_add_cancel (by omega : 5 * Nat.log2 n ≤ n) + nlinarith + have hblocks : (2 ^ k / s + 1) * s ≤ 2 ^ k + s := by + nlinarith [Nat.div_mul_le_self (2 ^ k) s] + calc + P * n * ((2 ^ k / s + 1) * 2 ^ d) ≤ + (P + 1) * s * ((2 ^ k / s + 1) * 2 ^ d) := by gcongr + _ = (P + 1) * ((2 ^ k / s + 1) * s) * 2 ^ d := by ring + _ ≤ (P + 1) * (2 ^ k + s) * 2 ^ d := by gcongr + _ = (P + 1) * 2 ^ n + (P + 1) * s * 2 ^ d := by + rw [show 2 ^ n = 2 ^ k * 2 ^ d by rw [← pow_add, hks]] + ring + _ ≤ (P + 1) * 2 ^ n + (P + 1) * n * 2 ^ d := by gcongr; exact Nat.sub_le _ _ + +/-- An error term of order `n · 2 ^ d` is `o(2 ^ n / n)`: with `d = n - 3 log₂ n`, +`c n ^ 2 · 2 ^ d ≤ 2 ^ n` once `n ≥ 8 c` and `3 log₂ n ≤ n`, using +`2 ^ (3 log₂ n) > (n / 2) ^ 3`. -/ +private theorem error_le (c n : ℕ) (hc : 8 * c ≤ n) (hn : 3 * Nat.log2 n ≤ n) : + c * n ^ 2 * 2 ^ (n - 3 * Nat.log2 n) ≤ 2 ^ n := by + let q := 2 ^ Nat.log2 n + have hq : n < 2 * q := by + simpa [q, pow_succ, Nat.mul_comm] using Nat.lt_log2_self (n := n) + have hcq : 4 * c ≤ q := by omega + have hpoly : c * n ^ 2 ≤ q ^ 3 := by + calc + c * n ^ 2 ≤ c * (2 * q) ^ 2 := by gcongr + _ = (4 * c) * q ^ 2 := by ring + _ ≤ q * q ^ 2 := by gcongr + _ = q ^ 3 := by ring + calc + c * n ^ 2 * 2 ^ (n - 3 * Nat.log2 n) ≤ q ^ 3 * 2 ^ (n - 3 * Nat.log2 n) := by gcongr + _ = 2 ^ n := by + dsimp [q] + rw [← pow_mul, ← pow_add] + congr 1 + omega + +/-- For every `P`, eventually `P n · bound ≤ (P + 1) 2 ^ n`; for `P > 0` this says the budget +is at most `(1 + 1 / P) · 2 ^ n / n`. Combines `bound_le`, `mainTerm_le`, +`Nat.eventually_mul_pow_le_pow`, and `error_le`; the slack `Q = 3 P` absorbs the constants in +the error terms. -/ +private theorem eventually_bound_le (P : ℕ) : + ∀ᶠ n : ℕ in atTop, + P * n * bound (3 * Nat.log2 n) (n - 3 * Nat.log2 n) (n - 5 * Nat.log2 n) ≤ + (P + 1) * 2 ^ n := by + let Q := 3 * P + -- The polynomial and data terms each contribute at most `2 ^ n` after scaling by `Q * n`. + filter_upwards [Nat.eventually_mul_log2_le (5 * (Q + 1) + 1), + Nat.eventually_mul_pow_le_pow (3 * Q) 5 Nat.one_lt_two, + eventually_ge_atTop (max 2 (8 * (17 * Q + 1)))] with n hlog hpoly hn + have hn2 : 2 ≤ n := (le_max_left _ _).trans hn + have hl : 0 < Nat.log2 n := (Nat.le_log2 (by omega)).mpr (by simpa using hn2) + have hstrict : 5 * Nat.log2 n < n := by nlinarith + have hremoved : (Q + 1) * (5 * Nat.log2 n) ≤ n := by nlinarith + have hmain := mainTerm_le Q n hstrict hremoved + have herr := error_le (17 * Q + 1) n ((le_max_right _ _).trans hn) (by omega) + have hbound := Nat.mul_le_mul_left (Q * n) (bound_le n hstrict) + have hsquare : n ≤ n ^ 2 := by nlinarith + have hmerge : (Q + 1) * n * 2 ^ (n - 3 * Nat.log2 n) ≤ + (Q + 1) * n ^ 2 * 2 ^ (n - 3 * Nat.log2 n) := by gcongr + have htotal : Q * n * bound (3 * Nat.log2 n) (n - 3 * Nat.log2 n) + (n - 5 * Nat.log2 n) ≤ (Q + 3) * 2 ^ n := by + nlinarith only [hmain, herr, hpoly, hbound, hmerge] + dsimp [Q] at htotal + nlinarith only [htotal] + +/-- Transport `synthesis` along `k + d = n`. -/ +private theorem exists_circuit_of_split {n k d s : ℕ} (h : k + d = n) (hs : 0 < s) + (f : BooleanFunction n) : ∃ g ≤ bound k d s, ∃ c : Circuit signature n g 1, + c.Computes interpretation f := by + subst n + exact (synthesis f hs).exists_circuit + +/-- Lupanov's upper bound: every Boolean function on `n` inputs has a De Morgan circuit +with at most `(1 + ε) 2ⁿ/n` gates, uniformly for sufficiently large `n`. + +Pick a natural number `P > 1 / ε`, so that `(P + 1) / P < 1 + ε`; then the threshold `N` +comes from `eventually_bound_le P`. -/ +theorem exists_circuit (ε : ℝ) (hε : 0 < ε) : + ∃ N : ℕ, ∀ n ≥ N, ∀ f : BooleanFunction n, + ∃ g, ∃ c : Circuit signature n g 1, + c.Computes interpretation f ∧ (c.size : ℝ) ≤ (1 + ε) * 2 ^ n / n := by + apply eventually_atTop.mp + obtain ⟨P, hP⟩ := exists_nat_gt (1 / ε) + have hP0 : (0 : ℝ) < P := lt_trans (by positivity) hP + have hcoefficient : (P : ℝ) + 1 ≤ (1 + ε) * P := by + have := (div_lt_iff₀ hε).mp hP + nlinarith + filter_upwards [eventually_bound_le P, Nat.eventually_mul_log2_le 6, + eventually_ge_atTop 2] with n hb hl hn + intro f + have hlog : 0 < Nat.log2 n := (Nat.le_log2 (by omega)).mpr (by simpa using hn) + have hsplit : 3 * Nat.log2 n + (n - 3 * Nat.log2 n) = n := by omega + obtain ⟨g, hg, c, hc⟩ := exists_circuit_of_split (s := n - 5 * Nat.log2 n) + hsplit (by omega) f + refine ⟨g, c, hc, ?_⟩ + have hcost : (P : ℝ) * n * g ≤ (P + 1 : ℝ) * 2 ^ n := by + exact_mod_cast (Nat.mul_le_mul_left (P * n) hg).trans hb + apply (le_div_iff₀ (by exact_mod_cast (by omega : 0 < n) : (0 : ℝ) < n)).mpr + apply (mul_le_mul_iff_right₀ hP0).mp + calc + (P : ℝ) * (g * n) = P * n * g := by ring + _ ≤ (P + 1) * 2 ^ n := hcost + _ ≤ P * ((1 + ε) * 2 ^ n) := by + nlinarith [mul_le_mul_of_nonneg_right hcoefficient (by positivity : (0 : ℝ) ≤ 2 ^ n)] + +end Cslib.Circuits.Boolean.Lupanov diff --git a/Cslib/Computability/Circuit/Boolean/LupanovConstruction.lean b/Cslib/Computability/Circuit/Boolean/LupanovConstruction.lean new file mode 100644 index 0000000000..9b006964fb --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/LupanovConstruction.lean @@ -0,0 +1,288 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Synthesis + +import Mathlib.Algebra.BigOperators.Fin + +/-! +# Lupanov's block construction + +This file is the finite, parametrised core of Lupanov's upper bound. Its purpose is to give a +gate budget `bound k d s` that is valid for every Boolean function on `k + d` inputs and every +positive block size `s`, and to prove (`synthesis`) that the budget suffices. The asymptotic file +`Lupanov.lean` then chooses `k`, `d`, and `s` as functions of `n` and shows that the budget is +`(1 + ε) 2 ^ n / n`. No asymptotics happen here. + +## Why not the disjunctive normal form? + +Writing `f` as the disjunction of its true minterms uses up to `2 ^ n` minterms of `n` +literals each, so roughly `n 2 ^ n` gates. The waste is that nothing is shared between +minterms. Lupanov's construction shares almost everything. + +## The picture + +Split the `n = k + d` inputs into `k` *address* bits and `d` *data* bits, and view the truth +table of `f` as a `2 ^ k × 2 ^ d` matrix: row `a` is an address assignment, column `b` is a +data assignment, and the entry is `f (a ++ b)`. Cut the rows into blocks of `s` consecutive +rows. Inside one block every column is a bit string of length `s`, its *pattern* in that +block; there are only `2 ^ s` possible patterns, however many columns there are. + +For each block `B` and pattern `v` define two functions: + +* `left B v`, of the address bits only: true at `a` when row `a` lies in `B` and `v` has a + `1` at the position of `a` within `B`; +* `right f B v`, of the data bits only: true at `b` when column `b` has pattern `v` in `B`. + +Both are functions of the full input that ignore the other half of it. Then +`left B v a ∧ right f B v b` holds exactly when `a` lies in `B`, `v` is the pattern of +column `b` inside `B`, and the entry `f (a ++ b)` is `true`. So `f` is the disjunction over +all pairs `(B, v)` of `left B v ∧ right f B v` (`table_eq`). + +## Counting gates + +All `2 ^ k` address minterms and `2 ^ d` data minterms are built once and shared. Each +`left B v` is a disjunction of at most `s` address minterms, so it costs `O(s)` gates, and +there are `(2 ^ k / s + 1) · 2 ^ s` of them. Each `right f B v` is a disjunction of data +minterms, one per column with pattern `v`; the columns of a block are partitioned by their +patterns (`support_card_sum`), so all the `right f B v` of one block together cost about +`2 ^ d` gates. Summing over blocks, the dominant contribution is + + `(2 ^ k / s) · 2 ^ d = 2 ^ n / s`. + +For the parameters chosen in `Lupanov.lean` the remaining terms are of lower order, and +`s ≈ n` makes this `2 ^ n / n`. The exact expression is `bound`. + +## References + +* [O. B. Lupanov, *On a Method of Circuit Synthesis*][Lupanov1958], + Section 1, equation (1.1), pp. 120-122: the original `(k, s)` representation. +* [Stasys Jukna, *Boolean Function Complexity: Advances and Frontiers*][Jukna2012], + Theorem 1.15: a modern exposition. +* [C. E. Shannon, *The Synthesis of Two-Terminal Switching Circuits*][Shannon1949], + Section 3(d), pp. 73-77: the earlier universal-network method for relay contacts. +-/ + +@[expose] public section + +namespace Cslib.Circuits.Boolean.Lupanov + +variable {k d s : ℕ} + +/-! ### Minterms -/ + +/-- An assignment to `k` Boolean variables. Address assignments index the rows of the truth +table and data assignments index its columns. -/ +private abbrev Assignment (k : ℕ) := Fin k → Bool + +/-- Number the address assignments as rows `0, …, 2 ^ k - 1`, interpreting the bits as +binary digits with the least significant bit first. -/ +private def index (k : ℕ) : Assignment k ≃ Fin (2 ^ k) := + (Equiv.arrowCongr (Equiv.refl (Fin k)) finTwoEquiv.symm).trans finFunctionFinEquiv + +/-- The minterm testing that the address bits equal `a` (`.inl a`) or that the data bits +equal `b` (`.inr b`). Both kinds are built once and shared by every block. -/ +private def minterm : Assignment k ⊕ Assignment d → BooleanFunction (k + d) + | .inl a => fun x => decide ((fun i => x (Fin.castAdd d i)) = a) + | .inr b => fun x => decide ((fun i => x (Fin.natAdd k i)) = b) + +/-- Build every address and data minterm from the inputs. Each costs `2 (k + d) + 1` gates +by `synthesis_minterm`. -/ +private theorem minterms_synthesis : + Synthesis interpretation (inputs (k + d)) (Set.range (minterm (k := k) (d := d))) + ((2 ^ k + 2 ^ d) * (2 * (k + d) + 1)) := by + have h (a : Assignment k ⊕ Assignment d) : + Synthesis interpretation (inputs (k + d)) {minterm a} (2 * (k + d) + 1) := by + cases a with + | inl a => + exact (synthesis_minterm (Fin.castAdd d) a).mono + Set.Subset.rfl Set.Subset.rfl (by omega) + | inr b => + exact (synthesis_minterm (Fin.natAdd k) b).mono + Set.Subset.rfl Set.Subset.rfl (by omega) + simpa using Synthesis.family minterm (fun _ => 2 * (k + d) + 1) h + +/-- Once the minterms have been built, each of them is free. -/ +private theorem minterm_available (a : Assignment k ⊕ Assignment d) : + Synthesis interpretation (Set.range minterm) {minterm a} 0 := + Synthesis.of_subset (by rintro _ rfl; exact ⟨a, rfl⟩) + +/-! ### The block decomposition + +Rows `block * s, …, block * s + s - 1` form block number `block`. The final block may be +partial, and when `s ∣ 2 ^ k` there is an empty extra block; rows past `2 ^ k` are read as +`false` throughout. -/ + +/-- The pattern of column `data` inside block `block`: the `s` entries of the truth table in +the block's rows, read down the column. -/ +private def column (f : BooleanFunction (k + d)) (block : ℕ) (data : Assignment d) : + Assignment s := + fun offset => if h : block * s + offset.val < 2 ^ k then + f (Fin.append ((index k).symm ⟨block * s + offset.val, h⟩) data) else false + +/-- The contribution of the row at `offset` within `block` to `left`: the address minterm of +that row when `pattern` is `1` there, and the constant `false` otherwise. -/ +private def leftRow (block : ℕ) (pattern : Assignment s) (offset : Fin s) : + BooleanFunction (k + d) := + if pattern offset then + if h : block * s + offset.val < 2 ^ k then + minterm (.inl ((index k).symm ⟨block * s + offset.val, h⟩)) + else fun _ => false + else fun _ => false + +/-- The address-only function of a block and pattern: true when the address lies in the +block, at an offset where the pattern is `1`. -/ +private def left (block : ℕ) (pattern : Assignment s) : BooleanFunction (k + d) := + fun x => decide (∃ offset, leftRow (d := d) block pattern offset x = true) + +/-- `left` is true exactly at inputs whose address is a row of the block, at an offset where +the pattern is `1`. -/ +private theorem left_eq_true (block : ℕ) (pattern : Assignment s) (x : Assignment (k + d)) : + left block pattern x = true ↔ ∃ offset : Fin s, + ∃ h : block * s + offset.val < 2 ^ k, + (index k).symm ⟨block * s + offset.val, h⟩ = (fun i => x (Fin.castAdd d i)) ∧ + pattern offset = true := by + simp only [left, decide_eq_true_eq] + apply exists_congr + intro offset + by_cases h : block * s + offset.val < 2 ^ k <;> + cases hp : pattern offset <;> simp [leftRow, hp, h, minterm, eq_comm] + +/-- The columns whose pattern inside `block` is `pattern`. For a fixed block, these sets +partition the columns. -/ +private def support (f : BooleanFunction (k + d)) (block : ℕ) (pattern : Assignment s) : + Finset (Assignment d) := Finset.univ.filter fun data => column f block data = pattern + +/-- The data-only function of a block and pattern: true when the data bits name a column +whose pattern inside the block is `pattern`. -/ +private def right (f : BooleanFunction (k + d)) (block : ℕ) (pattern : Assignment s) : + BooleanFunction (k + d) := + fun x => decide (∃ data ∈ support f block pattern, minterm (.inr data) x = true) + +/-- `right` is true exactly at inputs whose data bits name a column with the given pattern +inside the block. -/ +private theorem right_eq_true (f : BooleanFunction (k + d)) (block : ℕ) (pattern : Assignment s) + (x : Assignment (k + d)) : + right f block pattern x = true ↔ column f block (fun i => x (Fin.natAdd k i)) = pattern := by + simp [right, support, minterm, eq_comm] + +/-! ### Gate counts -/ + +/-- The supports of one block partition the `2 ^ d` columns. This is why all the `right` +parts of a block together cost only about `2 ^ d` gates. -/ +private theorem support_card_sum (f : BooleanFunction (k + d)) (block : ℕ) : + ∑ pattern : Assignment s, (support f block pattern).card = 2 ^ d := by + simpa [support] using (Finset.card_eq_sum_card_fiberwise + (s := Finset.univ) (t := Finset.univ) (f := column (s := s) f block) (by simp)).symm + +/-- A `left` part costs `2 s + 1` gates once the minterms are available: at most one gate per +row (a shared minterm costs nothing, a padding row needs a constant), one OR per row, and one +constant for the empty disjunction. -/ +private theorem left_synthesis (block : ℕ) (pattern : Assignment s) : + Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {left block pattern} (2 * s + 1) := by + have h (offset : Fin s) : + Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {leftRow block pattern offset} 1 := by + unfold leftRow + split + · split + · exact (minterm_available _).mono + Set.Subset.rfl Set.Subset.rfl (by omega : 0 ≤ 1) + · exact Synthesis.const false + · exact Synthesis.const false + change Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {fun x => decide (∃ offset, leftRow block pattern offset x = true)} (2 * s + 1) + simpa [Nat.mul_comm] using Synthesis.exists_mem Finset.univ + (leftRow (d := d) block pattern) (fun _ => 1) (fun i _ => h i) + +/-- A `right` part costs one OR per column in its support, plus one constant for the empty +disjunction, once the minterms are available. -/ +private theorem right_synthesis (f : BooleanFunction (k + d)) (block : ℕ) + (pattern : Assignment s) : + Synthesis interpretation (Set.range minterm) {right f block pattern} + ((support f block pattern).card + 1) := by + change Synthesis interpretation (Set.range (minterm (k := k) (d := d))) + {fun x => decide (∃ data ∈ support f block pattern, minterm (.inr data) x = true)} _ + simpa using Synthesis.exists_mem (support f block pattern) + (fun data => minterm (.inr data)) (fun _ => 0) + (fun data _ => minterm_available (.inr data)) + +/-! ### Correctness -/ + +/-- The disjunction over all blocks and patterns of `left ∧ right`. Block numbers range over +`2 ^ k / s + 1` values to include a partial final block. -/ +private def table (f : BooleanFunction (k + d)) (s : ℕ) : BooleanFunction (k + d) := + fun x => decide (∃ pair : Fin (2 ^ k / s + 1) × Assignment s, + (left pair.1.val pair.2 x && right f pair.1.val pair.2 x) = true) + +/-- The block decomposition reconstructs `f`. At an input `a ++ b` with `f (a ++ b) = true`, +the witnessing pair is the block containing row `a` and the pattern of column `b` in that +block. -/ +private theorem table_eq (f : BooleanFunction (k + d)) (hs : 0 < s) : table f s = f := by + funext x + apply Bool.eq_iff_iff.mpr + simp only [table, decide_eq_true_eq, Prod.exists, Bool.and_eq_true, + left_eq_true, right_eq_true] + constructor + · rintro ⟨block, pattern, ⟨offset, hrow, haddress, hbit⟩, hpattern⟩ + rw [← hpattern] at hbit + simpa [column, hrow, haddress, Fin.append_castAdd_natAdd] using hbit + · intro hx + let address := index k (fun i => x (Fin.castAdd d i)) + let block : Fin (2 ^ k / s + 1) := + ⟨address.val / s, Nat.lt_succ_of_le (Nat.div_le_div_right address.isLt.le)⟩ + let offset : Fin s := ⟨address.val % s, Nat.mod_lt _ hs⟩ + have hrow : block.val * s + offset.val = address.val := Nat.div_add_mod' _ _ + have hvalid : block.val * s + offset.val < 2 ^ k := hrow ▸ address.isLt + have haddress : (index k).symm ⟨block.val * s + offset.val, hvalid⟩ = + (fun i => x (Fin.castAdd d i)) := by + rw [show (⟨block.val * s + offset.val, hvalid⟩ : Fin (2 ^ k)) = address by + exact Fin.ext hrow] + exact (index k).symm_apply_apply _ + refine ⟨block, column f block.val (fun i => x (Fin.natAdd k i)), + ⟨offset, hvalid, haddress, ?_⟩, rfl⟩ + simpa [column, hvalid, haddress, Fin.append_castAdd_natAdd] using hx + +/-! ### The bound -/ + +/-- Gate budget for `k` address bits, `d` data bits, and blocks of `s` rows, as spent by +`synthesis`. In order: the shared minterms; then for each of the `2 ^ k / s + 1` blocks +(a partial final block, or an empty extra block when `s ∣ 2 ^ k`), `2 s + 4` gates per +pattern, namely `2 s + 1` for its `left` part, the constant starting its `right` part, the +conjunction of the two, and the OR into the running disjunction, plus `2 ^ d` gates in total +for the ORs inside the `right` parts of the block, one per column; and one constant for the +empty outer disjunction. The leading term is `(2 ^ k / s) · 2 ^ d ≈ 2 ^ n / s`. -/ +def bound (k d s : ℕ) : ℕ := + (2 ^ k + 2 ^ d) * (2 * (k + d) + 1) + + (2 ^ k / s + 1) * (2 ^ s * (2 * s + 4) + 2 ^ d) + 1 + +/-- Every Boolean function on `k + d` inputs can be built from the input projections within +`bound k d s` gates: build all minterms, then the disjunction over block-pattern pairs of +`left ∧ right`, which equals `f` by `table_eq`. -/ +theorem synthesis (f : BooleanFunction (k + d)) (hs : 0 < s) : + Synthesis interpretation (inputs (k + d)) {f} (bound k d s) := by + have hpair (pair : Fin (2 ^ k / s + 1) × Assignment s) := + (left_synthesis (d := d) pair.1.val pair.2).and (right_synthesis f pair.1.val pair.2) + have h := Synthesis.exists_mem Finset.univ + (fun pair : Fin (2 ^ k / s + 1) × Assignment s => + fun x => left pair.1.val pair.2 x && right f pair.1.val pair.2 x) + (fun pair => (2 * s + 1) + ((support f pair.1.val pair.2).card + 1) + 1) + (fun pair _ => hpair pair) + have hsum : (∑ pair : Fin (2 ^ k / s + 1) × Assignment s, + ((2 * s + 1) + ((support f pair.1.val pair.2).card + 1) + 1 + 1)) = + (2 ^ k / s + 1) * (2 ^ s * (2 * s + 4) + 2 ^ d) := by + simp_rw [show ∀ a : ℕ, (2 * s + 1) + (a + 1) + 1 + 1 = (2 * s + 4) + a by omega] + simp [Fintype.sum_prod_type, Finset.sum_add_distrib, support_card_sum, Nat.mul_add, + Nat.mul_assoc] + simp only [Finset.mem_univ, true_and, hsum] at h + change Synthesis interpretation _ {table f s} _ at h + rw [table_eq f hs] at h + simpa [bound, Nat.add_assoc] using minterms_synthesis.comp + (h.mono Set.subset_union_right Set.Subset.rfl le_rfl) + +end Cslib.Circuits.Boolean.Lupanov diff --git a/Cslib/Computability/Circuit/Boolean/Shannon.lean b/Cslib/Computability/Circuit/Boolean/Shannon.lean new file mode 100644 index 0000000000..33901b156c --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Shannon.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Shannon + +/-! +# Shannon's lower bound for De Morgan circuits + +This is the De Morgan specialization of `Cslib.Circuits.Shannon.exists_hard_function`. +Together with Lupanov's construction, it gives the asymptotically sharp gate count `2ⁿ/n`. +-/ + +public section + +namespace Cslib.Circuits.Boolean.Shannon + +/-- For all sufficiently large `n`, some Boolean function on `n` inputs requires +more than `2ⁿ/n` De Morgan gates, counting constants and negations. -/ +theorem exists_hard_function : + ∃ N : ℕ, ∀ n ≥ N, ∃ f : BooleanFunction n, + ∀ {g} (c : Circuit signature n g 1), + c.Computes interpretation f → 2 ^ n / (n : ℝ) < (c.size : ℝ) := by + simpa [Nat.card_eq_fintype_card] using + Circuits.Shannon.exists_hard_function interpretation (fun op => by cases op <;> simp) + +end Cslib.Circuits.Boolean.Shannon diff --git a/Cslib/Computability/Circuit/Boolean/Synthesis.lean b/Cslib/Computability/Circuit/Boolean/Synthesis.lean new file mode 100644 index 0000000000..a9e021a6cc --- /dev/null +++ b/Cslib/Computability/Circuit/Boolean/Synthesis.lean @@ -0,0 +1,110 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Boolean.Basic +public import Cslib.Computability.Circuit.Synthesis +public import Mathlib.Data.Fintype.Card + +/-! +# Boolean synthesis + +The generic synthesis rules specialize to the De Morgan basis: constants, negation, conjunction, +and disjunction. Finite conjunctions and disjunctions use the generic fold bound, and +`synthesis_minterm` combines literals to test a specified tuple of input bits. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +open Boolean + +universe u +variable {n : ℕ} {ι : Type u} + +namespace Synthesis + +variable {s : Set (BooleanFunction n)} {a b : ℕ} {f g : BooleanFunction n} + +/-- Constants cost one gate. -/ +theorem const (value : Bool) : Synthesis interpretation s {fun _ => value} 1 := + nullary (I := interpretation) (.const value) rfl + +/-- Apply negation to a synthesized function. -/ +theorem not (h : Synthesis interpretation s {f} a) : + Synthesis interpretation s {fun x => !f x} (a + 1) := + h.unary .not + +/-- Binary conjunction costs one gate beyond its arguments. -/ +theorem and (hf : Synthesis interpretation s {f} a) (hg : Synthesis interpretation s {g} b) : + Synthesis interpretation s {fun x => f x && g x} (a + b + 1) := by + simpa [interpretation] using hf.binary hg .and + +/-- Binary disjunction costs one gate beyond its arguments. -/ +theorem or (hf : Synthesis interpretation s {f} a) (hg : Synthesis interpretation s {g} b) : + Synthesis interpretation s {fun x => f x || g x} (a + b + 1) := by + simpa [interpretation] using hf.binary hg .or + +/-- Disjoin a finite family of functions. The extra gate supplies the empty disjunction. -/ +theorem exists_mem (indices : Finset ι) (f : ι → BooleanFunction n) (cost : ι → ℕ) + (h : ∀ i ∈ indices, Synthesis interpretation s {f i} (cost i)) : + Synthesis interpretation s {fun x => decide (∃ i ∈ indices, f i x = true)} + ((∑ i ∈ indices, (cost i + 1)) + 1) := by + have hop (f g : BooleanFunction n) : + Synthesis interpretation {f, g} {fun x => f x || g x} 1 := by + simpa [interpretation] using gate (I := interpretation) (s := {f, g}) .or + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + have heq : (fun x => indices.fold Bool.or false (fun i => f i x)) = + (fun x => decide (∃ i ∈ indices, f i x = true)) := by + funext x + apply Bool.eq_iff_iff.mpr + simpa using Finset.fold_op_rel_iff_or (op := Bool.or) + (r := fun _ v : Bool => v = true) (by simp) (c := true) + (s := indices) (f := fun i => f i x) (b := false) + simpa only [heq] using finset_fold Bool.or 1 hop indices f cost + (fun _ => false) (const false) h + +/-- Conjoin a finite family of functions. The extra gate supplies the empty conjunction. -/ +theorem forall_mem (indices : Finset ι) (f : ι → BooleanFunction n) (cost : ι → ℕ) + (h : ∀ i ∈ indices, Synthesis interpretation s {f i} (cost i)) : + Synthesis interpretation s {fun x => decide (∀ i ∈ indices, f i x = true)} + ((∑ i ∈ indices, (cost i + 1)) + 1) := by + have hop (f g : BooleanFunction n) : + Synthesis interpretation {f, g} {fun x => f x && g x} 1 := by + simpa [interpretation] using gate (I := interpretation) (s := {f, g}) .and + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + have heq : (fun x => indices.fold Bool.and true (fun i => f i x)) = + (fun x => decide (∀ i ∈ indices, f i x = true)) := by + funext x + apply Bool.eq_iff_iff.mpr + simpa using Finset.fold_op_rel_iff_and (op := Bool.and) + (r := fun _ v : Bool => v = true) (by simp) (c := true) + (s := indices) (f := fun i => f i x) (b := true) + simpa only [heq] using finset_fold Bool.and 1 hop indices f cost + (fun _ => true) (const true) h + +end Synthesis + +namespace Boolean + +/-- A conjunction testing a specified tuple of input bits. -/ +theorem synthesis_minterm {k : ℕ} (wires : Fin k → Fin n) (value : Fin k → Bool) : + Synthesis interpretation (inputs n) {fun x => decide ((fun i => x (wires i)) = value)} + (2 * k + 1) := by + have literal (i : Fin k) : + Synthesis interpretation (inputs n) {fun x => decide (x (wires i) = value i)} 1 := by + have h : Synthesis interpretation (inputs n) {fun x => x (wires i)} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨wires i, rfl⟩) + cases hv : value i + · simpa [hv] using h.not + · simpa [hv] using h.mono Set.Subset.rfl Set.Subset.rfl (by omega : 0 ≤ 1) + have h := Synthesis.forall_mem Finset.univ + (fun i x => decide (x (wires i) = value i)) (fun _ => 1) (fun i _ => literal i) + simpa [funext_iff, Nat.mul_comm] using h + +end Boolean +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Counting.lean b/Cslib/Computability/Circuit/Counting.lean new file mode 100644 index 0000000000..441369d896 --- /dev/null +++ b/Cslib/Computability/Circuit/Counting.lean @@ -0,0 +1,210 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Finite +public import Cslib.Computability.Circuit.Normalization +public import Mathlib.Data.Finset.Card +public import Mathlib.Data.Nat.Factorial.Basic +public import Mathlib.Tactic.ToAdditive + +import Mathlib.Algebra.BigOperators.Ring.Finset +import Mathlib.Algebra.Order.BigOperators.Group.Finset +import Mathlib.Data.Fintype.BigOperators +import Mathlib.Data.Fintype.Perm +import Mathlib.Tactic.GCongr +import Mathlib.Tactic.NormNum + +/-! +# Counting functions computed by finite circuits + +For a finite signature, only finitely many functions can be computed with a fixed gate budget, +even when the carrier is infinite. We enumerate circuit syntax and collect its scalar functions. +Semantic equality and normalization use classical reasoning; the syntax enumeration is computable. + +After merging gates that compute the same function, a circuit with `g` gates has `g!` distinct +labeled presentations. This factorial correction sharpens the count used in Shannon's lower bound. +The main bound accepts any uniform bound on the number of lines; +`card_computableFunctions_mul_factorial_le_of_arity_le` specializes it to operation arities. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +open scoped BigOperators + +universe v u +variable {σ : Signature.{v}} [Fintype σ.Op] {U : Type u} +variable {I : Interpretation σ U} {n g s : ℕ} + +/-- Scalar functions computable with at most `s` gates. Enumerating circuit syntax makes +this family finite without requiring a finite carrier. -/ +noncomputable def computableFunctions (I : Interpretation σ U) (n s : ℕ) : + Finset ((Fin n → U) → U) := + open scoped Classical in + (Finset.range (s + 1)).biUnion fun g => + Finset.univ.image fun c : Circuit σ n g 1 => fun x => c.eval I x 0 + +@[simp] theorem mem_computableFunctions {f : (Fin n → U) → U} : + f ∈ computableFunctions I n s ↔ ∃ g ≤ s, ∃ c : Circuit σ n g 1, c.Computes I f := by + classical + simp [computableFunctions, Circuit.Computes, funext_iff, Nat.lt_succ_iff] + +/-- Functions computed by circuits with exactly `g` pairwise semantically distinct gates. +Each such function has `g!` distinct presentations obtained by relabeling its chosen circuit. -/ +noncomputable def irredundantFunctions (I : Interpretation σ U) (n g : ℕ) : + Finset ((Fin n → U) → U) := + open scoped Classical in + (Finset.univ.filter fun c : Circuit σ n g 1 => c.Irredundant I).image + fun c => fun x => c.eval I x 0 + +@[simp] theorem mem_irredundantFunctions {f : (Fin n → U) → U} : + f ∈ irredundantFunctions I n g ↔ ∃ c : Circuit σ n g 1, + c.Computes I f ∧ c.Irredundant I := by + classical + simp [irredundantFunctions, Circuit.Computes, funext_iff, and_comm] + +section Relabeling + +omit [Fintype σ.Op] + +-- Gate equations and an output wire, without a topological ordering. +private abbrev Presentation (n g : ℕ) := (Fin g → Line σ n g) × Wire n g + +private def relabel (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) : + Presentation (σ := σ) n g := + (fun a => (c.program.lines (π.symm a)).mapWires (Wire.Renaming.ofPermutation π), + Wire.Renaming.ofPermutation π (c.outputs 0)) + +private theorem relabel_line_eval (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) + (x : Fin n → U) (v : Fin g → U) (a : Fin g) : + ((relabel c π).1 a).eval I x v = + (c.program.lines (π.symm a)).eval I x (v ∘ π) := by + apply Line.eval_mapRenaming + intro gate + simp [Wire.Renaming.ofPermutation] + +private theorem relabel_unique (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) + (x : Fin n → U) (v : Fin g → U) + (h : ∀ a, ((relabel c π).1 a).eval I x v = v a) : + v = c.program.eval I x ∘ π.symm := by + have hv : v ∘ π = c.program.eval I x := + c.program.eq_eval_of_forall_lines_eval I x _ (fun a => by + simpa [relabel_line_eval] using h (π a)) + funext a + simpa using congrFun hv (π.symm a) + +private theorem relabel_output (c : Circuit σ n g 1) (π : Equiv.Perm (Fin g)) + (x : Fin n → U) : + Fin.addCases x (c.program.eval I x ∘ π.symm) (relabel c π).2 = + c.eval I x 0 := by + apply Wire.Renaming.value_apply + intro gate + simp [Wire.Renaming.ofPermutation, Function.comp_def] + +end Relabeling + +private noncomputable def representative (f : irredundantFunctions I n g) : + Circuit σ n g 1 := + (mem_irredundantFunctions.mp f.property).choose + +private theorem representative_spec (f : irredundantFunctions I n g) : + (representative f).Computes I f ∧ + (representative f).Irredundant I := + (mem_irredundantFunctions.mp f.property).choose_spec + +-- Equal presentations determine the function; distinct gate functions determine the labels. +private theorem relabel_injective : Function.Injective + (fun p : irredundantFunctions I n g × Equiv.Perm (Fin g) => + relabel (representative p.1) p.2) := by + rintro ⟨f, π⟩ ⟨f', τ⟩ heq + dsimp only at heq + have hvalues (x : Fin n → U) : + (representative f).program.eval I x ∘ π.symm = + (representative f').program.eval I x ∘ τ.symm := by + apply relabel_unique + intro a + rw [← heq, relabel_line_eval] + simpa [Function.comp_def] using + (representative f).program.lines_eval I x (π.symm a) + have hfunction : f = f' := by + apply Subtype.ext + funext x + rw [← (representative_spec f).1 x, ← (representative_spec f').1 x, + ← relabel_output _ π, ← relabel_output _ τ, heq, hvalues] + subst f' + have hpermutation : π.symm = τ.symm := by + apply Equiv.ext + intro a + apply (representative_spec f).2 + funext x + exact congrFun (hvalues x) a + exact Prod.ext rfl (by simpa using congrArg Equiv.symm hpermutation) + +/-- Distinct functions and permutations of their irredundant gates give distinct presentations. -/ +theorem card_irredundantFunctions_mul_factorial_le (I : Interpretation σ U) (n g : ℕ) : + (irredundantFunctions I n g).card * g.factorial ≤ + Fintype.card (Line σ n g) ^ g * (n + g) := by + classical + have h := Fintype.card_le_of_injective _ (relabel_injective (I := I) (n := n) (g := g)) + simpa only [Fintype.card_prod, Fintype.card_coe, Fintype.card_perm, Fintype.card_fin, + Fintype.card_fun] using h + +/-- Normalizing a circuit places its function in one of the irredundant families. -/ +theorem card_computableFunctions_le_sum (I : Interpretation σ U) (n s : ℕ) : + (computableFunctions I n s).card ≤ + ∑ g ∈ Finset.range (s + 1), (irredundantFunctions I n g).card := by + classical + apply le_trans (Finset.card_le_card (t := + (Finset.range (s + 1)).biUnion (irredundantFunctions I n)) ?_) Finset.card_biUnion_le + intro f hf + obtain ⟨g, hg, c, hc⟩ := mem_computableFunctions.mp hf + obtain ⟨k, hk, d, hd, hinj⟩ := c.exists_irredundant I + apply Finset.mem_biUnion.mpr + refine ⟨k, Finset.mem_range.mpr (by omega), mem_irredundantFunctions.mpr ⟨d, ?_, hinj⟩⟩ + simpa only [Circuit.Computes, hd] using hc + +/-- Bound the number of computable functions using a uniform line count `B`. The condition +`s ≤ B` absorbs the extra factorial factors from circuits with fewer than `s` gates. -/ +theorem card_computableFunctions_mul_factorial_le (I : Interpretation σ U) (n s B : ℕ) + (hB : s ≤ B) (hlines : ∀ g ≤ s, Fintype.card (Line σ n g) ≤ B) : + (computableFunctions I n s).card * s.factorial ≤ + (s + 1) * B ^ s * (n + s) := by + have hterm (g : ℕ) (hg : g ≤ s) : + (irredundantFunctions I n g).card * s.factorial ≤ B ^ s * (n + s) := by + calc + (irredundantFunctions I n g).card * s.factorial = + ((irredundantFunctions I n g).card * g.factorial) * + (g + 1).ascFactorial (s - g) := by + rw [mul_assoc, Nat.factorial_mul_ascFactorial, Nat.add_sub_of_le hg] + _ ≤ (Fintype.card (Line σ n g) ^ g * (n + g)) * s ^ (s - g) := + Nat.mul_le_mul (card_irredundantFunctions_mul_factorial_le I n g) + (by simpa [Nat.add_sub_of_le hg] using Nat.ascFactorial_le_pow_add g (s - g)) + _ ≤ (B ^ g * (n + s)) * B ^ (s - g) := by gcongr; exact hlines g hg + _ = B ^ s * (n + s) := by rw [mul_right_comm, ← pow_add, Nat.add_sub_of_le hg] + calc + (computableFunctions I n s).card * s.factorial ≤ + (∑ g ∈ Finset.range (s + 1), (irredundantFunctions I n g).card) * s.factorial := + Nat.mul_le_mul_right _ (card_computableFunctions_le_sum I n s) + _ ≤ ∑ _g ∈ Finset.range (s + 1), B ^ s * (n + s) := by + rw [Finset.sum_mul] + exact Finset.sum_le_sum fun g hg => hterm g (Nat.le_of_lt_succ (Finset.mem_range.mp hg)) + _ = (s + 1) * B ^ s * (n + s) := by simp [mul_assoc] + +/-- A cardinality bound for any finite signature with bounded arities. The maximum also +covers empty signatures and signatures containing only nullary operations. -/ +theorem card_computableFunctions_mul_factorial_le_of_arity_le + (I : Interpretation σ U) (n s r : ℕ) (arity_le : ∀ op, σ.Arity op ≤ r) : + (computableFunctions I n s).card * s.factorial ≤ + (s + 1) * (max s (Fintype.card σ.Op * (n + s + 1) ^ r)) ^ s * (n + s) := by + apply card_computableFunctions_mul_factorial_le I n s _ (Nat.le_max_left _ _) + intro g hg + exact (Line.card_le n g r arity_le).trans + ((Nat.mul_le_mul_left _ (Nat.pow_le_pow_left (by omega : n + g + 1 ≤ n + s + 1) r)).trans + (Nat.le_max_right _ _)) + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Finite.lean b/Cslib/Computability/Circuit/Finite.lean new file mode 100644 index 0000000000..32850f9b5a --- /dev/null +++ b/Cslib/Computability/Circuit/Finite.lean @@ -0,0 +1,84 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic +public import Mathlib.Data.Fintype.BigOperators + +import Mathlib.Algebra.Order.BigOperators.Group.Finset + +/-! +# Finite circuit syntax + +A finite signature gives computable enumerations of lines, programs, and circuits of each +fixed size. Their cardinalities count syntax and are independent of any interpretation or +carrier. `Line.card_le` bounds the number of lines when all operation arities are bounded. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +universe v +variable {σ : Signature.{v}} [Fintype σ.Op] + +instance Line.instFintype (n g : ℕ) : Fintype (Line σ n g) := + Fintype.ofEquiv _ (Line.equiv σ n g).symm + +instance Program.instFintype (n : ℕ) : (g : ℕ) → Fintype (Program σ n g) + | 0 => Fintype.ofEquiv PUnit (Program.emptyEquiv σ n).symm + | g + 1 => + letI := Program.instFintype n g + Fintype.ofEquiv _ (Program.gateEquiv σ n g).symm + +instance Circuit.instFintype (n g m : ℕ) : Fintype (Circuit σ n g m) := + Fintype.ofEquiv _ (Circuit.equiv σ n g m).symm + +/-- For each operation, choose one wire for each of its arguments. -/ +theorem Line.card (n g : ℕ) : + Fintype.card (Line σ n g) = ∑ op : σ.Op, (n + g) ^ σ.Arity op := by + rw [Fintype.card_congr (Line.equiv σ n g), Fintype.card_sigma] + simp + +/-- A uniform arity bound gives a uniform bound on the number of lines, including when +there are no available wires. -/ +theorem Line.card_le (n g r : ℕ) (arity_le : ∀ op, σ.Arity op ≤ r) : + Fintype.card (Line σ n g) ≤ Fintype.card σ.Op * (n + g + 1) ^ r := by + rw [Line.card] + calc + ∑ op : σ.Op, (n + g) ^ σ.Arity op ≤ ∑ _op : σ.Op, (n + g + 1) ^ r := by + apply Finset.sum_le_sum + intro op _ + exact (Nat.pow_le_pow_left (by omega : n + g ≤ n + g + 1) _).trans + (Nat.pow_le_pow_right (by omega) (arity_le op)) + _ = _ := by simp + +/-- There is one empty program, regardless of the signature or number of inputs. -/ +@[simp] theorem Program.card_zero (n : ℕ) : Fintype.card (Program σ n 0) = 1 := by + rw [Fintype.card_congr (Program.emptyEquiv σ n)] + simp + +/-- Choose a prefix program and then its last line. -/ +theorem Program.card_succ (n g : ℕ) : + Fintype.card (Program σ n (g + 1)) = + Fintype.card (Program σ n g) * Fintype.card (Line σ n g) := by + rw [Fintype.card_congr (Program.gateEquiv σ n g), Fintype.card_prod] + +/-- The line at each position may refer to the inputs and all preceding gates. -/ +theorem Program.card (n g : ℕ) : + Fintype.card (Program σ n g) = + ∏ j ∈ Finset.range g, ∑ op : σ.Op, (n + j) ^ σ.Arity op := by + induction g with + | zero => simp + | succ g ih => simp [Program.card_succ, ih, Line.card, Finset.prod_range_succ] + +/-- Each output independently selects an input or internal-gate wire. -/ +theorem Circuit.card (n g m : ℕ) : + Fintype.card (Circuit σ n g m) = Fintype.card (Program σ n g) * (n + g) ^ m := by + rw [Fintype.card_congr (Circuit.equiv σ n g m), Fintype.card_prod] + simp + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Normalization.lean b/Cslib/Computability/Circuit/Normalization.lean new file mode 100644 index 0000000000..24f71e1197 --- /dev/null +++ b/Cslib/Computability/Circuit/Normalization.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic +import Mathlib.Data.Fin.Tuple.Basic + +/-! +# Semantic circuit normalization + +Merging gates that compute the same function preserves wire values and does not +increase circuit size. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +variable {σ : Signature} {n g m : ℕ} {U : Type*} + +/-- Distinct gates compute distinct scalar functions. Gates may still duplicate input +functions or be unused by the outputs. -/ +def Program.Irredundant (p : Program σ n g) (i : Interpretation σ U) : Prop := + Function.Injective (p.gateFunction i) + +/-- A circuit is irredundant when its internal gates compute pairwise distinct functions. -/ +def Circuit.Irredundant (c : Circuit σ n g m) (i : Interpretation σ U) : Prop := + c.program.Irredundant i + +/-- A program can be rebuilt with distinct gate functions, preserving every wire's value. -/ +theorem Program.exists_irredundant (p : Program σ n g) (i : Interpretation σ U) : + ∃ k ≤ g, ∃ q : Program σ n k, ∃ ρ : Wire.Renaming n g k, + (∀ x w, q.trace i x (ρ w) = p.trace i x w) ∧ + q.Irredundant i := by + classical + induction p with + | empty => + exact ⟨0, le_rfl, .empty, .id, by simp, fun w => Fin.elim0 w⟩ + | @gate g p line ih => + obtain ⟨k, hk, q, ρ, hρ, hq⟩ := ih + let l := line.mapWires ρ + have hl (x) : l.eval i x (q.eval i x) = line.eval i x (p.eval i x) := + line.eval_mapWires ρ i x x (p.eval i x) (q.eval i x) (hρ x) + by_cases h : ∃ w, q.gateFunction i w = fun x => l.eval i x (q.eval i x) + · obtain ⟨w, hw⟩ := h + refine ⟨k, by omega, q, ρ.skipLast (Wire.gate w), ?_, hq⟩ + intro x v + refine Fin.lastCases ?_ (fun v => ?_) v + · simpa using (congrFun hw x).trans (hl x) + · simpa using hρ x v + · refine ⟨k + 1, by omega, q.gate l, ρ.appendLast, ?_, ?_⟩ + · intro x v + refine Fin.lastCases ?_ (fun v => ?_) v + · simpa using hl x + · simpa using hρ x v + · change Function.Injective ((q.gate l).gateFunction i) + convert Fin.snoc_injective_of_injective hq h using 1 + ext gate x + refine Fin.lastCases ?_ (fun gate => ?_) gate <;> simp + +/-- Every circuit has an equivalent circuit with distinct gate functions and no more gates. -/ +theorem Circuit.exists_irredundant (c : Circuit σ n g m) (i : Interpretation σ U) : + ∃ k ≤ g, ∃ d : Circuit σ n k m, + d.eval i = c.eval i ∧ d.Irredundant i := by + obtain ⟨k, hk, q, ρ, hρ, hq⟩ := c.program.exists_irredundant i + exact ⟨k, hk, ⟨q, ρ ∘ c.outputs⟩, funext fun x => funext fun o => hρ x (c.outputs o), hq⟩ + +end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Program.lean b/Cslib/Computability/Circuit/Program.lean index 47de25b02c..28a5622c09 100644 --- a/Cslib/Computability/Circuit/Program.lean +++ b/Cslib/Computability/Circuit/Program.lean @@ -46,6 +46,14 @@ structure Line (σ : Signature) (inputCount gateCount : Nat) where /-- The wire supplying each argument of the operation. -/ wires : Fin (σ.Arity op) → Wire inputCount gateCount +/-- A line is an operation symbol together with a tuple of argument wires. -/ +def Line.equiv (σ : Signature) (inputCount gateCount : Nat) : + Line σ inputCount gateCount ≃ Σ op : σ.Op, Fin (σ.Arity op) → Wire inputCount gateCount where + toFun line := ⟨line.op, line.wires⟩ + invFun line := ⟨line.1, line.2⟩ + left_inv _ := rfl + right_inv _ := rfl + /-- Apply a function to every wire read by a line. -/ def Line.mapWires (line : Line σ sourceInputCount sourceGateCount) @@ -72,6 +80,22 @@ inductive Program (σ : Signature.{v}) (inputCount : Nat) : Nat → Type v where Program σ inputCount gateCount → Line σ inputCount gateCount → Program σ inputCount (gateCount + 1) +/-- The empty program is the only program with no gates. -/ +def Program.emptyEquiv (σ : Signature) (inputCount : Nat) : Program σ inputCount 0 ≃ PUnit.{1} where + toFun _ := PUnit.unit + invFun _ := .empty + left_inv p := by cases p; rfl + right_inv x := by cases x; rfl + +/-- A nonempty program is a prefix followed by its last gate. -/ +def Program.gateEquiv (σ : Signature) (inputCount gateCount : Nat) : + Program σ inputCount (gateCount + 1) ≃ + Program σ inputCount gateCount × Line σ inputCount gateCount where + toFun | .gate p line => (p, line) + invFun p := p.1.gate p.2 + left_inv p := by cases p; rfl + right_inv _ := rfl + /-- Every gate in a program has at most `r` arguments. -/ def Program.FanInAtMost {gateCount : Nat} : (program : Program σ inputCount gateCount) → Nat → Prop | .empty, _ => True @@ -403,4 +427,27 @@ theorem Program.lines_eval · simp only [Program.lines_gate_castSucc, Program.eval_gate_castSucc] exact (evalWidened (program.lines priorGate)).trans (ih priorGate) +/-- A valuation satisfying every gate equation is the program's evaluation. -/ +theorem Program.eq_eval_of_forall_lines_eval + (p : Program σ inputCount gateCount) (i : Interpretation σ U) (x : Fin inputCount → U) + (values : Fin gateCount → U) + (h : ∀ gate, (p.lines gate).eval i x values = values gate) : + values = p.eval i x := by + induction p with + | empty => exact Subsingleton.elim _ _ + | @gate g p line ih => + have hmap (l : Line σ inputCount g) : + (l.mapWires Wire.Renaming.castSucc).eval i x values = + l.eval i x (values ∘ Fin.castSucc) := by + apply Line.eval_mapWires + intro w + refine Fin.addCases (fun a => ?_) (fun b => ?_) w <;> + simp [Wire.Renaming.castSucc, Function.comp_def] + have hp : values ∘ Fin.castSucc = p.eval i x := + ih _ (fun gate => by simpa [hmap] using h gate.castSucc) + funext gate + refine Fin.lastCases ?_ (fun gate => ?_) gate + · simpa [hmap, hp] using (h (Fin.last g)).symm + · simpa using congrFun hp gate + end Cslib.Circuits diff --git a/Cslib/Computability/Circuit/Shannon.lean b/Cslib/Computability/Circuit/Shannon.lean new file mode 100644 index 0000000000..38f7a30328 --- /dev/null +++ b/Cslib/Computability/Circuit/Shannon.lean @@ -0,0 +1,148 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Counting +public import Mathlib.Basic.Real.Basic +public import Mathlib.SetTheory.Cardinal.Finite + +import Cslib.Foundations.Data.Nat.Asymptotics +import Cslib.Foundations.Data.Nat.Factorial +import Mathlib.Analysis.SpecialFunctions.Log.Basic +import Mathlib.Order.Filter.AtTopBot.Basic + +/-! +# Shannon's lower bound for finite carriers and binary bases + +For any fixed finite signature with operation arities at most two, interpreted on a finite +carrier `U` with `q ≥ 2` elements, some function on `n` inputs requires more than `qⁿ/n` gates +for all sufficiently large `n`. The threshold may depend on the signature and carrier. +For the De Morgan basis on `Bool`, this matches Lupanov's upper bound asymptotically. + +The logarithm of the counting bound is at most `s log s + O(s)` for `n + 1 ≤ s`. +At `s = ⌊qⁿ/n⌋`, this is smaller than the logarithm of the `q^(qⁿ)` functions. +This extends the Boolean counting argument in the references to finite carriers. + +## References + +* [Claude E. Shannon, *The Synthesis of Two-Terminal Switching Circuits*][Shannon1949]: + Theorem 7, Section 3(e), pp. 77-79, the original counting argument for switching circuits. +* [Stasys Jukna, *Boolean Function Complexity: Advances and Frontiers*][Jukna2012]: + Lemma 1.12 and Theorem 1.14, a modern treatment of Boolean circuit counting. +-/ + +public section + +namespace Cslib.Circuits.Shannon + +open Filter + +universe v u +variable {σ : Signature.{v}} {U : Type u} + +private theorem exists_card_le_exp [Fintype σ.Op] (I : Interpretation σ U) + (arity_le : ∀ op, σ.Arity op ≤ 2) : + ∃ C : ℝ, ∀ n s : ℕ, n + 1 ≤ s → + ((computableFunctions I n s).card : ℝ) ≤ Real.exp ((s : ℝ) * Real.log s + C * s) := by + let q := Fintype.card σ.Op + 1 + have hq : 1 ≤ q := Nat.succ_le_succ (Nat.zero_le _) + refine ⟨Real.log (4 * (q : ℝ)) + 5, fun n s hn => ?_⟩ + let a := (computableFunctions I n s).card + by_cases ha : a = 0 + · simp only [show (computableFunctions I n s).card = 0 from ha, Nat.cast_zero] + positivity + have ha : (0 : ℝ) < a := by exact_mod_cast (Nat.pos_of_ne_zero ha) + have hs : (1 : ℝ) ≤ s := by exact_mod_cast (by omega : 1 ≤ s) + have hn' : (n : ℝ) + 1 ≤ s := by exact_mod_cast hn + have hB : s ≤ q * (n + s + 1) ^ 2 := by + calc + s ≤ (n + s + 1) ^ 2 := by nlinarith [Nat.le_mul_self (n + s + 1)] + _ ≤ q * (n + s + 1) ^ 2 := by + simpa only [one_mul] using Nat.mul_le_mul_right ((n + s + 1) ^ 2) hq + have hlines (g : ℕ) (hg : g ≤ s) : Fintype.card (Line σ n g) ≤ q * (n + s + 1) ^ 2 := + (Line.card_le n g 2 arity_le).trans (Nat.mul_le_mul (Nat.le_succ _) + (Nat.pow_le_pow_left (by omega : n + g + 1 ≤ n + s + 1) 2)) + have hcount : (a : ℝ) * s.factorial ≤ + (2 * (s : ℝ)) ^ 2 * (4 * (q : ℝ) * (s : ℝ) ^ 2) ^ s := by + calc + (a : ℝ) * s.factorial ≤ + ((s : ℝ) + 1) * ((q : ℝ) * ((n : ℝ) + s + 1) ^ 2) ^ s * (n + s) := by + exact_mod_cast card_computableFunctions_mul_factorial_le I n s _ hB hlines + _ ≤ (2 * s) * ((q : ℝ) * (2 * (s : ℝ)) ^ 2) ^ s * (2 * s) := by + gcongr <;> linarith + _ = _ := by rw [show (q : ℝ) * (2 * (s : ℝ)) ^ 2 = 4 * q * s ^ 2 by ring]; ring + have hlog : Real.log a + Real.log s.factorial ≤ + 2 * (Real.log 2 + Real.log s) + s * (Real.log (4 * (q : ℝ)) + 2 * Real.log s) := by + simpa [Real.log_mul, Real.log_pow, ne_of_gt ha, Nat.factorial_ne_zero, + ne_of_gt (zero_lt_one.trans_le hs)] using + (Real.log_le_log (by positivity : 0 < (a : ℝ) * s.factorial) hcount) + apply (Real.log_le_iff_le_exp ha).mp + have hfactorial := Nat.mul_log_sub_le_log_factorial s + have hlogtwo := Real.log_le_sub_one_of_pos (by norm_num : (0 : ℝ) < 2) + have hlogs := Real.log_le_self (by positivity : (0 : ℝ) ≤ s) + nlinarith + +private theorem eventually_card_lt [Fintype σ.Op] [Fintype U] [Nontrivial U] + (I : Interpretation σ U) (arity_le : ∀ op, σ.Arity op ≤ 2) : + ∀ᶠ n : ℕ in atTop, (computableFunctions I n (Fintype.card U ^ n / n)).card < + Fintype.card U ^ (Fintype.card U ^ n) := by + let q := Fintype.card U + have hq : 1 < q := Fintype.one_lt_card + have hqR : (1 : ℝ) < q := by exact_mod_cast hq + have hlogq : 0 < Real.log q := Real.log_pos hqR + obtain ⟨C, hC⟩ := exists_card_le_exp I arity_le + obtain ⟨t, ht⟩ := exists_nat_gt (C / Real.log q) + have hgap : C < t * Real.log q := (div_lt_iff₀ hlogq).mp ht + filter_upwards [Nat.eventually_add_one_le_pow_div hq, eventually_ge_atTop t, + eventually_ge_atTop (q ^ t)] with n hn htn hlarge + let s := q ^ n / n + have hs : (0 : ℝ) < s := by exact_mod_cast (by dsimp [s]; omega : 0 < s) + have hshift : s ≤ q ^ (n - t) := by + apply Nat.div_le_of_le_mul + calc + q ^ n = q ^ t * q ^ (n - t) := by rw [← pow_add, Nat.add_sub_of_le htn] + _ ≤ n * q ^ (n - t) := Nat.mul_le_mul_right _ hlarge + have hlog : Real.log s ≤ ((n : ℝ) - t) * Real.log q := by + have h := Real.log_le_log hs (show (s : ℝ) ≤ (q : ℝ) ^ (n - t) by exact_mod_cast hshift) + simpa [Real.log_pow, Nat.cast_sub htn] using h + have hsize : (n : ℝ) * s ≤ (q : ℝ) ^ n := by + exact_mod_cast (Nat.mul_div_le (q ^ n) n) + have hexponent : (s : ℝ) * Real.log s + C * s < + (q : ℝ) ^ n * Real.log q := by + nlinarith only [mul_le_mul_of_nonneg_left hlog hs.le, + mul_le_mul_of_nonneg_right hsize hlogq.le, mul_lt_mul_of_pos_right hgap hs] + have hcount : ((computableFunctions I n s).card : ℝ) < (q : ℝ) ^ (q ^ n : ℕ) := by + calc + _ ≤ Real.exp ((s : ℝ) * Real.log s + C * s) := hC n s hn + _ < Real.exp ((q : ℝ) ^ n * Real.log q) := Real.exp_lt_exp.mpr hexponent + _ = (q : ℝ) ^ (q ^ n : ℕ) := by + rw [show (q : ℝ) ^ n = ((q ^ n : ℕ) : ℝ) by norm_cast, + Real.exp_nat_mul, Real.exp_log (zero_lt_one.trans hqR)] + exact_mod_cast hcount + +/-- For all sufficiently large `n`, some function on `n` inputs over `U` requires more than +`|U|ⁿ/n` gates over the fixed finite signature, whose operations have arity at most two. -/ +theorem exists_hard_function [Finite σ.Op] [Finite U] [Nontrivial U] + (I : Interpretation σ U) (arity_le : ∀ op, σ.Arity op ≤ 2) : + ∃ N : ℕ, ∀ n ≥ N, ∃ f : (Fin n → U) → U, + ∀ {g} (c : Circuit σ n g 1), + c.Computes I f → (Nat.card U : ℝ) ^ n / n < (c.size : ℝ) := by + classical + let := Fintype.ofFinite σ.Op + let := Fintype.ofFinite U + simp only [Nat.card_eq_fintype_card] + apply eventually_atTop.mp + filter_upwards [eventually_card_lt I arity_le, eventually_ge_atTop 1] with n hn hn0 + obtain ⟨f, _, hf⟩ := Finset.exists_mem_notMem_of_card_lt_card + (s := computableFunctions I n (Fintype.card U ^ n / n)) (t := Finset.univ) + (by simpa only [Fintype.card_fun, Fintype.card_fin, Finset.card_univ] using hn) + refine ⟨f, fun {g} c hc => ?_⟩ + have hg : Fintype.card U ^ n / n < g := lt_of_not_ge fun hg => + hf (mem_computableFunctions.mpr ⟨g, hg, c, hc⟩) + apply (div_lt_iff₀ (by exact_mod_cast (by omega : 0 < n) : (0 : ℝ) < n)).mpr + exact_mod_cast (Nat.div_lt_iff_lt_mul (by omega : 0 < n)).mp hg + +end Cslib.Circuits.Shannon diff --git a/Cslib/Computability/Circuit/Synthesis.lean b/Cslib/Computability/Circuit/Synthesis.lean new file mode 100644 index 0000000000..7362f013df --- /dev/null +++ b/Cslib/Computability/Circuit/Synthesis.lean @@ -0,0 +1,238 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Computability.Circuit.Basic +public import Mathlib.Algebra.BigOperators.Group.Finset.Basic +public import Mathlib.Data.Finset.Fold +public import Mathlib.Data.Fintype.Basic +public import Mathlib.Data.Set.BooleanAlgebra +public import Mathlib.Data.Set.Lattice.Bounded + +/-! +# Simultaneous circuit synthesis + +`Synthesis I sources targets cost` bounds the number of additional gates needed to compute +`targets` from `sources` under an interpretation `I`. Every function already available in the +starting program remains available, so successive constructions can share intermediate results. +The signature and its carrier are arbitrary; neither needs to be finite or decidable. + +The core rules compose bounds, combine finite families, and apply operations of the signature. +The fold rules accept a bound for combining two arguments, which may itself use several gates. +`Synthesis.exists_circuit_family` selects any finite family of outputs without adding gates; +`Synthesis.exists_circuit` specializes this to a single output. +-/ + +@[expose] public section + +namespace Cslib.Circuits + +universe v u w +variable {σ : Signature.{v}} {U : Type u} {n : ℕ} {ι : Type w} +variable {I : Interpretation σ U} + +/-- The coordinate projections supplied by the circuit's inputs. -/ +def inputs (n : ℕ) : Set ((Fin n → U) → U) := Set.range fun i x => x i + +/-- The functions computed by the wires of `p`, whether input wires or internal +gates. -/ +def available (I : Interpretation σ U) {g : ℕ} (p : Program σ n g) : Set ((Fin n → U) → U) := + Set.range (p.wireFunction I) + +/-- A function is available exactly when some wire computes it pointwise. -/ +theorem mem_available {g : ℕ} {p : Program σ n g} {f : (Fin n → U) → U} : + f ∈ available I p ↔ ∃ w, ∀ x, p.trace I x w = f x := by + simp [available, Program.wireFunction, funext_iff] + +/-- The input projections are available in every program. -/ +theorem inputs_subset_available {g : ℕ} (p : Program σ n g) : + inputs n ⊆ available I p := by + rintro _ ⟨i, rfl⟩ + exact ⟨Wire.input i, p.wireFunction_input I i⟩ + +/-- `Synthesis I sources targets cost` says that `targets` can be computed from `sources` +using at most `cost` additional gates, without losing anything already computed. + +Precisely: for every program `p₁` on whose wires every function in `sources` is available, +there is a program `p₂` such that +* `p₂` has at most `cost` more gates than `p₁`, +* every function available in `p₁` is still available in `p₂`, and +* every function in `targets` is available in `p₂`. + +Quantifying over an arbitrary starting program, rather than the empty one, is what lets +constructions share intermediate results: `Synthesis.comp` adds budgets because the second +construction may reuse wires built by the first. -/ +def Synthesis (I : Interpretation σ U) (sources targets : Set ((Fin n → U) → U)) + (cost : ℕ) : Prop := + ∀ (g₁ : ℕ) (p₁ : Program σ n g₁), sources ⊆ available I p₁ → + ∃ (g₂ : ℕ) (p₂ : Program σ n g₂), g₂ ≤ g₁ + cost ∧ + available I p₁ ⊆ available I p₂ ∧ targets ⊆ available I p₂ + +namespace Synthesis + +variable {s t t₁ : Set ((Fin n → U) → U)} {a b : ℕ} {f g : (Fin n → U) → U} + +/-- Available functions require no additional gates. -/ +theorem of_subset (h : t ⊆ s) : Synthesis I s t 0 := + fun g p hp => ⟨g, p, by omega, Set.Subset.rfl, h.trans hp⟩ + +/-- Enlarge the source family, narrow the target family, or increase the budget. -/ +theorem mono (h : Synthesis I s t a) {s' t' : Set ((Fin n → U) → U)} + (hs : s ⊆ s') (ht : t' ⊆ t) (hab : a ≤ b) : Synthesis I s' t' b := by + intro g₁ p hp + obtain ⟨g₂, q, hq, hkeep, hout⟩ := h g₁ p (hs.trans hp) + exact ⟨g₂, q, by omega, hkeep, ht.trans hout⟩ + +/-- Successive constructions add their gate budgets. -/ +theorem comp (h : Synthesis I s t a) (h' : Synthesis I (s ∪ t) t₁ b) : + Synthesis I s t₁ (a + b) := by + intro g₁ p hp + obtain ⟨g₂, q, hq, hpq, ht⟩ := h g₁ p hp + obtain ⟨g₃, r, hr, hqr, hu⟩ := h' g₂ q (Set.union_subset (hp.trans hpq) ht) + exact ⟨g₃, r, by omega, hpq.trans hqr, hu⟩ + +/-- Combine two target families, preserving the first while constructing the second. -/ +theorem union (h : Synthesis I s t a) (h' : Synthesis I s t₁ b) : + Synthesis I s (t ∪ t₁) (a + b) := by + intro g₁ p hp + obtain ⟨g₂, q, hq, hpq, ht⟩ := h g₁ p hp + obtain ⟨g₃, r, hr, hqr, hu⟩ := h' g₂ q (hp.trans hpq) + exact ⟨g₃, r, by omega, hpq.trans hqr, Set.union_subset (ht.trans hqr) hu⟩ + +/-- Synthesize an operation whose arguments are already available. -/ +theorem gate (op : σ.Op) (args : Fin (σ.Arity op) → (Fin n → U) → U) + (hargs : ∀ i, args i ∈ s) : + Synthesis I s {fun x => I op (fun i => args i x)} 1 := by + classical + intro g₁ p hp + choose wires hw using fun i => mem_available.mp (hp (hargs i)) + let line : Line σ n g₁ := ⟨op, wires⟩ + refine ⟨g₁ + 1, p.gate line, le_rfl, ?_, ?_⟩ + · intro f hf + obtain ⟨w, hw'⟩ := mem_available.mp hf + exact mem_available.mpr + ⟨w.castSucc, fun x => (Program.trace_gate_castSucc _ _ _ _ _).trans (hw' x)⟩ + · rw [Set.singleton_subset_iff, mem_available] + refine ⟨Fin.last (n + g₁), fun x => ?_⟩ + rw [Program.trace_gate_last] + change I op (fun i => p.trace I x (wires i)) = _ + simp only [hw] + +/-- Combine a finite family of target sets, retaining all earlier results. -/ +theorem biUnion (indices : Finset ι) (targets : ι → Set ((Fin n → U) → U)) + (cost : ι → ℕ) (h : ∀ i ∈ indices, Synthesis I s (targets i) (cost i)) : + Synthesis I s (⋃ i ∈ indices, targets i) (∑ i ∈ indices, cost i) := by + classical + induction indices using Finset.induction_on with + | empty => exact of_subset (by simp) + | @insert i indices hi ih => + simpa [Finset.sum_insert hi] using + (h i (by simp)).union (ih (fun j hj => h j (by simp [hj]))) + +/-- Combine target sets indexed by a finite type. -/ +theorem iUnion [Fintype ι] (targets : ι → Set ((Fin n → U) → U)) (cost : ι → ℕ) + (h : ∀ i, Synthesis I s (targets i) (cost i)) : + Synthesis I s (⋃ i, targets i) (∑ i, cost i) := by + simpa using biUnion Finset.univ targets cost (fun i _ => h i) + +/-- Simultaneously synthesize an indexed finite family of functions. -/ +theorem family [Fintype ι] (f : ι → (Fin n → U) → U) (cost : ι → ℕ) + (h : ∀ i, Synthesis I s {f i} (cost i)) : + Synthesis I s (Set.range f) (∑ i, cost i) := by + simpa using iUnion (fun i => {f i}) cost h + +/-- Synthesize every argument, then apply an operation with one further gate. -/ +theorem gate_of_syntheses (op : σ.Op) (args : Fin (σ.Arity op) → (Fin n → U) → U) + (cost : Fin (σ.Arity op) → ℕ) (h : ∀ i, Synthesis I s {args i} (cost i)) : + Synthesis I s {fun x => I op (fun i => args i x)} ((∑ i, cost i) + 1) := + (family args cost h).comp (gate op args (fun i => Set.mem_union_right _ ⟨i, rfl⟩)) + +/-- A nullary operation supplies its interpreted constant with one gate. -/ +theorem nullary (op : σ.Op) (arity : σ.Arity op = 0) : + Synthesis I s {fun _ => I op (fun i => Fin.elim0 (Fin.cast arity i))} 1 := + gate op (fun i _ => Fin.elim0 (Fin.cast arity i)) (fun i => Fin.elim0 (Fin.cast arity i)) + +/-- Feed a synthesized function to every argument of an operation, using one further gate. +In particular, this applies a unary operation. -/ +theorem unary (h : Synthesis I s {f} a) (op : σ.Op) : + Synthesis I s {fun x => I op (fun _ => f x)} (a + 1) := + h.comp (gate op (fun _ => f) (by simp)) + +/-- Feed `f` to argument zero and `g` to the remaining arguments, using one further gate. +For a binary operation, these are its two arguments. -/ +theorem binary (hf : Synthesis I s {f} a) (hg : Synthesis I s {g} b) (op : σ.Op) : + Synthesis I s {fun x => I op (fun i => if i.val = 0 then f x else g x)} + (a + b + 1) := by + simpa only [ite_apply] using (hf.union hg).comp + (gate op (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp)) + +/-- Apply a synthesis bound to two previously synthesized arguments. The combining +construction can use several gates and can reuse either argument. -/ +theorem combine {result : (Fin n → U) → U} {c : ℕ} + (hf : Synthesis I s {f} a) (hg : Synthesis I s {g} b) + (h : Synthesis I {f, g} {result} c) : Synthesis I s {result} (a + b + c) := by + apply (hf.union hg).comp + apply h.mono ?_ Set.Subset.rfl le_rfl + intro k hk + exact Set.mem_union_right _ (by simpa [or_comm] using hk) + +/-- Fold an ordered list of synthesized functions. No algebraic laws are needed for the +combining operation. The seed and the combining construction have their own gate budgets. -/ +theorem foldr (op : U → U → U) (combineCost : ℕ) + (hop : ∀ f g : (Fin n → U) → U, + Synthesis I {f, g} {fun x => op (f x) (g x)} combineCost) + (indices : List ι) (f : ι → (Fin n → U) → U) (cost : ι → ℕ) + (seed : (Fin n → U) → U) (hseed : Synthesis I s {seed} a) + (h : ∀ i ∈ indices, Synthesis I s {f i} (cost i)) : + Synthesis I s {fun x => indices.foldr (fun i acc => op (f i x) acc) (seed x)} + ((indices.map fun i => cost i + combineCost).sum + a) := by + induction indices with + | nil => simpa using hseed + | cons i indices ih => + have step := (h i (by simp)).combine + (ih (fun j hj => h j (by simp [hj]))) (hop _ _) + simpa [Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using step + +/-- Fold a finite set of synthesized functions with a commutative associative operation. +The seed need not be an identity or a constant, and the combining construction may use +several gates. -/ +theorem finset_fold (op : U → U → U) [Std.Commutative op] [Std.Associative op] + (combineCost : ℕ) (hop : ∀ f g : (Fin n → U) → U, + Synthesis I {f, g} {fun x => op (f x) (g x)} combineCost) + (indices : Finset ι) (f : ι → (Fin n → U) → U) (cost : ι → ℕ) + (seed : (Fin n → U) → U) (hseed : Synthesis I s {seed} a) + (h : ∀ i ∈ indices, Synthesis I s {f i} (cost i)) : + Synthesis I s {fun x => indices.fold op (seed x) (fun i => f i x)} + ((∑ i ∈ indices, (cost i + combineCost)) + a) := by + classical + induction indices using Finset.induction_on with + | empty => simpa using hseed + | @insert i indices hi ih => + have step := (h i (by simp)).combine + (ih (fun j hj => h j (by simp [hj]))) (hop _ _) + simpa [Finset.fold_insert hi, Finset.sum_insert hi, + Nat.add_assoc, Nat.add_comm, Nat.add_left_comm] using step + +/-- Select a finite family of outputs from a synthesis bound. Selecting outputs, including +repeated outputs or an empty family, requires no additional gates. -/ +theorem exists_circuit_family {m cost : ℕ} {f : Fin m → (Fin n → U) → U} + (h : Synthesis I (inputs n) (Set.range f) cost) : + ∃ g ≤ cost, ∃ c : Circuit σ n g m, ∀ x j, c.eval I x j = f j x := by + classical + obtain ⟨g, p, hg, _, hout⟩ := h 0 .empty (inputs_subset_available _) + choose wires hw using fun j => mem_available.mp (hout ⟨j, rfl⟩) + exact ⟨g, by simpa using hg, ⟨p, wires⟩, fun x j => hw j x⟩ + +/-- Extract a single-output circuit from a synthesis bound on the input projections. -/ +theorem exists_circuit {cost : ℕ} (h : Synthesis I (inputs n) {f} cost) : + ∃ g ≤ cost, ∃ c : Circuit σ n g 1, c.Computes I f := by + have h' : Synthesis I (inputs n) (Set.range fun _ : Fin 1 => f) cost := by + simpa using h + obtain ⟨g, hg, c, hc⟩ := h'.exists_circuit_family + exact ⟨g, hg, c, fun x => hc x 0⟩ + +end Synthesis +end Cslib.Circuits diff --git a/Cslib/Computability/Languages/Congruences/Basic.lean b/Cslib/Computability/Languages/Congruences/Basic.lean new file mode 100644 index 0000000000..a895216e38 --- /dev/null +++ b/Cslib/Computability/Languages/Congruences/Basic.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Ching-Tsun Chou +-/ + +module + +public import Cslib.Init +public import Mathlib.Computability.Language + +/-! +# Right Congruence + +This file contains basic definitions about left, right, and (two-sided) congruences +on finite sequences. +-/ + +@[expose] public section + +namespace Language + +variable {α : Type*} + +/-- A right congruence is an equivalence relation on finite sequences (represented by lists) +that is preserved by concatenation on the right. The equivalence relation is represented +by a setoid to to enable ready access to the quotient construction. -/ +class RightCongruence (α : Type*) extends eq : Setoid (List α) where + right_cov : CovariantClass _ _ (fun x y => y ++ x) eq + +namespace RightCongruence + +/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ +abbrev eqvCls [c : RightCongruence α] (a : Quotient c.eq) : Language α := + (Quotient.mk c.eq) ⁻¹' {a} + +end RightCongruence + +/-- A left congruence is an equivalence relation on finite sequences (represented by lists) +that is preserved by concatenation on the left. The equivalence relation is represented +by a setoid to to enable ready access to the quotient construction. -/ +class LeftCongruence (α : Type*) extends eq : Setoid (List α) where + left_cov : CovariantClass _ _ (fun x y => x ++ y) eq + +namespace LeftCongruence + +/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ +abbrev eqvCls [c : LeftCongruence α] (a : Quotient c.eq) : Language α := + (Quotient.mk c.eq) ⁻¹' {a} + +end LeftCongruence + +/-- A (two-sided) congruence is an equivalence relation on finite sequences (represented by lists) +that is both a left-congruence and a right-congruence. -/ +class Congruence (α : Type*) extends LeftCongruence α, RightCongruence α where + +namespace Congruence + +/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ +abbrev eqvCls [c : Congruence α] (a : Quotient c.eq) : Language α := + (Quotient.mk c.eq) ⁻¹' {a} + +end Congruence + +end Language diff --git a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean index c9855f0736..0444cd3307 100644 --- a/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean +++ b/Cslib/Computability/Languages/Congruences/BuchiCongruence.lean @@ -22,6 +22,7 @@ of ω-regular languages under complementation. namespace Cslib.Automata.NA.Buchi open Function Set Filter ωAcceptor ωLanguage ωSequence +open _root_.Language RightCongruence variable {Symbol : Type*} {State : Type} @@ -186,14 +187,14 @@ theorem buchiFamily_saturation [Inhabited Symbol] : obtain ⟨ss, ⟨h_init, h_exec⟩, h_acc⟩ := h_lang let f (k : ℕ) := xl.length + xls.cumLen k let ts := ωSequence.mk (fun k ↦ ss (f k)) - have (k : ℕ) : xls k ≠ [] := by grind [Language.mem_sub_one] + have (k : ℕ) : xls k ≠ [] := by grind have h_xls_p (k : ℕ) : (xls k).length > 0 := List.length_pos_iff.mpr (this k) have h_xls_e (k : ℕ) : xls k ∈ na.pairLang (ts k) (ts (k + 1)) := by grind [LTS.OmegaExecution.extract_mTr h_exec (?_ : f k ≤ f (k + 1)), LTS.mem_pairLang, extract_append_right_right, add_tsub_cancel_left] have h_yls (k : ℕ) := buchiCongruence_transfer ((h_xls_c k).left) ((h_yls_c k).left) (h_xls_e k) choose sls h_yls_e h_yls_a using h_yls - have (k : ℕ) : yls k ≠ [] := by grind [Language.mem_sub_one] + have (k : ℕ) : yls k ≠ [] := by grind have h_yls_p (k : ℕ) : (yls k).length > 0 := List.length_pos_iff.mpr (this k) obtain ⟨ss1, h_ss1_run, h_ss1_seg⟩ := LTS.OmegaExecution.flatten_execution h_yls_e h_yls_p suffices ∃ᶠ (k : ℕ) in atTop, ss1 k ∈ na.accept by diff --git a/Cslib/Computability/Languages/Congruences/MyhillCongruence.lean b/Cslib/Computability/Languages/Congruences/MyhillCongruence.lean new file mode 100644 index 0000000000..6dfaa1f2b8 --- /dev/null +++ b/Cslib/Computability/Languages/Congruences/MyhillCongruence.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Ching-Tsun Chou +-/ + +module + +public import Cslib.Computability.Languages.MyhillNerode + +/-! # Myhill congruence + +The Myhill congruence of a language `l` is a two-sided congruence that is finer than +the Nerode congruence of the same language `l` (which is a right congruence). It will be +used to define the syntactic monoid of `l`. + +## References + +[Holcombe1982] Holcombe, W.M.L. (1982). Algebraic automata theory. Section 5.3 +-/ + +@[expose] public section + +variable {α : Type} + +namespace Language + +open Cslib Language Automata DA FinAcc Acceptor +open scoped RightCongruence + +/-- The Myhill congruence of a language `l` is the two-sided congruence on finite words +such that two words are related iff all their two-sided extensions are either both in `l` +or both not in `l`. -/ +@[implicit_reducible] +def MyhillCongruence (l : Language α) : Congruence α where + r x y := ∀ w z, w ++ x ++ z ∈ l ↔ w ++ y ++ z ∈ l + iseqv.refl := by grind + iseqv.symm := by grind + iseqv.trans := by grind + right_cov.elim := by grind [Covariant] + left_cov.elim := by grind [Covariant] + +/-- The Myhill quotient of a language `l` is the quotient of its Myhill congruence. -/ +abbrev MyhillQuotient (l : Language α) := Quotient l.MyhillCongruence.eq + +/-- Given a language `l` and a finite word `x`, the Nerode map is a map from the Nerode quotient +to itself induced by the `x`-transition of the Nerode congruence deterministic automaton of `l`. -/ +def nerodeMap (l : Language α) (x : List α) : l.NerodeQuotient → l.NerodeQuotient := + fun q ↦ l.NerodeCongruenceDA.mtr q x + +theorem nerodeMap_append (l : Language α) (x y : List α) : + l.nerodeMap (x ++ y) = l.nerodeMap y ∘ l.nerodeMap x := by + ext q + simp [nerodeMap, FLTS.mtr_append_eq] + +theorem nerodeMap_accept (l : Language α) (x : List α) : + x ∈ l ↔ l.nerodeMap x l.NerodeCongruenceDA.start ∈ l.NerodeCongruenceDA.accept := by + nth_rewrite 1 [← nerodeCongruenceDA_language_eq l] + constructor <;> intro <;> assumption + +/-- The Myhill congruence is in fact the congruence induced by the Nerode map. -/ +theorem myhillCongruence_iff (l : Language α) (x y : List α) : + l.MyhillCongruence.r x y ↔ l.nerodeMap x = l.nerodeMap y := by + constructor <;> intro h + · ext q + obtain ⟨w, rfl⟩ := Quotient.mk_surjective q + simp only [nerodeMap, NerodeCongruenceDA, congr_mtr_append, Quotient.eq_iff_equiv] + exact h w + · intro w z + simp [nerodeMap_accept, nerodeMap_append, h] + +/-- The Myhill quotient of a regular language is finite. -/ +theorem IsRegular.finite_myhillQuotient {l : Language α} + (h : l.IsRegular) : Finite (l.MyhillQuotient) := by + have h1 : l.MyhillCongruence.eq = Setoid.ker l.nerodeMap := by + ext + exact myhillCongruence_iff _ _ _ + rw [MyhillQuotient, h1] + have := IsRegular.finite_nerodeQuotient h + have : Finite (l.NerodeQuotient → l.NerodeQuotient) := inferInstance + exact Finite.of_injective _ (Setoid.kerLift_injective l.nerodeMap) + +/-- The deterministic automaton corresponding to the Myhill congruence of a language `l`. -/ +def myhillCongruenceDA (l : Language α) : DA.FinAcc (l.MyhillQuotient) α := + FinAcc.mk l.MyhillCongruence.toDA ((⟦·⟧) '' l) + +/-- The deterministic automaton corresponding to the Myhill congruence of a language `l` +accepts the same language `l`. -/ +theorem myhillCongruenceDA_language_eq (l : Language α) : + language (l.myhillCongruenceDA) = l := by + ext x + simp only [myhillCongruenceDA, language, Acceptor.Accepts, + congr_mtr_eq (c := l.MyhillCongruence.toRightCongruence)] + constructor + · rintro ⟨y, hy, heq⟩ + have h1 := Quotient.eq.mp heq [] [] + simp only [List.append_nil, List.nil_append] at h1 + simpa [← h1] + · intro hx + use x, hx + congr + +/-- A language is regular if and only if its Myhill quotient is finite. -/ +theorem IsRegular.iff_finite_myhillQuotient (l : Language α) : + l.IsRegular ↔ Finite (l.MyhillQuotient) := by + apply Iff.intro + case mp => exact IsRegular.finite_myhillQuotient + case mpr => + intro h + apply IsRegular.iff_dfa.mpr + use l.MyhillQuotient, h, l.myhillCongruenceDA, myhillCongruenceDA_language_eq l + +end Language diff --git a/Cslib/Computability/Languages/Congruences/RightCongruence.lean b/Cslib/Computability/Languages/Congruences/RightCongruence.lean deleted file mode 100644 index b1da41a95c..0000000000 --- a/Cslib/Computability/Languages/Congruences/RightCongruence.lean +++ /dev/null @@ -1,41 +0,0 @@ -/- -Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. -Released under Apache 2.0 license as described in the file LICENSE. -Authors: Ching-Tsun Chou --/ - -module - -public import Cslib.Init -public import Mathlib.Computability.Language - -/-! -# Right Congruence - -This file contains basic definitions about right congruences on finite sequences. - -NOTE: Left congruences and two-sided congruences can be similarly defined. -But they are left to future work because they are not needed for now. --/ - -@[expose] public section - -namespace Cslib - -/-- A right congruence is an equivalence relation on finite sequences (represented by lists) -that is preserved by concatenation on the right. The equivalence relation is represented -by a setoid to to enable ready access to the quotient construction. -/ -class RightCongruence (α : Type*) extends eq : Setoid (List α) where - right_cov : CovariantClass _ _ (fun x y => y ++ x) eq - -namespace RightCongruence - -variable {α : Type*} - -/-- The equivalence class (as a language) corresponding to an element of the quotient type. -/ -abbrev eqvCls [c : RightCongruence α] (a : Quotient c.eq) : Language α := - (Quotient.mk c.eq) ⁻¹' {a} - -end RightCongruence - -end Cslib diff --git a/Cslib/Computability/Languages/MyhillNerode.lean b/Cslib/Computability/Languages/MyhillNerode.lean index 9823cbe595..568a374521 100644 --- a/Cslib/Computability/Languages/MyhillNerode.lean +++ b/Cslib/Computability/Languages/MyhillNerode.lean @@ -161,7 +161,7 @@ end Language namespace Cslib.Automata.DA.FinAcc open Cslib Cslib.Language Automata DA FinAcc Acceptor -open scoped RightCongruence +open _root_.Language RightCongruence /-- The minimal DFA accepting `l` has the same number of states as the number of equivalence classes of the Nerode congruence on `l`. -/ diff --git a/Cslib/Computability/Languages/RegularLanguage.lean b/Cslib/Computability/Languages/RegularLanguage.lean index ae70a9fee4..c38577a311 100644 --- a/Cslib/Computability/Languages/RegularLanguage.lean +++ b/Cslib/Computability/Languages/RegularLanguage.lean @@ -14,6 +14,8 @@ public import Cslib.Computability.Automata.DA.Prod public import Cslib.Computability.Automata.NA.Reverse public import Cslib.Computability.Automata.NA.ToDA public import Cslib.Computability.Automata.DA.ToNA +public import Cslib.Computability.Automata.TwoWayNA.OfNA +public import Cslib.Computability.Automata.TwoWayNA.ComplToNA public import Mathlib.Computability.DFA public import Mathlib.Computability.RegularExpressions public import Mathlib.Basic.Finite.Sum @@ -27,7 +29,7 @@ public import Mathlib.Data.Set.Card namespace Cslib.Language -open Set List Prod Automata Acceptor RightCongruence +open Set List Prod Automata Acceptor open scoped Computability FLTS DA NA DA.FinAcc NA.FinAcc variable {Symbol Symbol' : Type*} @@ -70,6 +72,23 @@ theorem IsRegular.compl {l : Language Symbol} (h : l.IsRegular) : (lᶜ).IsRegul simp only [language, Accepts] rfl +/-- A language is regular if and only if it is accepted by some two-way nondeterministic +automaton with finitely many states. -/ +theorem IsRegular.iff_twoWayNA {l : Language Symbol} : + l.IsRegular ↔ ∃ State : Type, ∃ _ : Finite State, + ∃ a : TwoWayNA State Symbol, language a = l := by + constructor + · intro h + rw [IsRegular.iff_nfa] at h + obtain ⟨State, hfin, na, rfl⟩ := h + exact ⟨State, hfin, NA.FinAcc.toTwoWayNA na, TwoWayNA.language_toTwoWayNA na⟩ + · rintro ⟨State, hfin, a, rfl⟩ + have := hfin + have hc : (language a)ᶜ.IsRegular := by + rw [IsRegular.iff_nfa] + exact ⟨Set State × Set State, inferInstance, a.complToNA, a.language_complToNA⟩ + simpa using hc.compl + /-- The empty language is regular. -/ @[simp] theorem IsRegular.zero : (0 : Language Symbol).IsRegular := by @@ -183,6 +202,7 @@ theorem IsRegular.kstar {l : Language Symbol} obtain ⟨State, h_fin, nfa, rfl⟩ := h use Unit ⊕ Option State, inferInstance, ⟨finLoop nfa, {inl ()}⟩, loop_language_eq h_l +open _root_.Language RightCongruence in /-- If a right congruence is of finite index, then each of its equivalence classes is regular. -/ @[simp] theorem IsRegular.congr_fin_index {Symbol : Type} diff --git a/Cslib/Computability/Languages/SyntacticMonoid.lean b/Cslib/Computability/Languages/SyntacticMonoid.lean new file mode 100644 index 0000000000..00a89e8f5a --- /dev/null +++ b/Cslib/Computability/Languages/SyntacticMonoid.lean @@ -0,0 +1,48 @@ +/- +Copyright (c) 2026 Ching-Tsun Chou. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Ching-Tsun Chou +-/ + +module + +public import Cslib.Computability.Languages.Congruences.MyhillCongruence + +/-! # Syntactic monoid + +This file defines the syntactic monoid of a language `l` and shows that +`l` is regular if and only if its syntactic monoid is finite. + +## References + +[Holcombe1982] Holcombe, W.M.L. (1982). Algebraic automata theory. Section 5.3 +-/ + +@[expose] public section + +variable {α : Type} + +namespace Language + +open Cslib.Language + +/-- Converting a (two-sided) congruence `c` on finite words to a congruence relation +on the (multiplicative) free monoid. -/ +def Congruence.toCon [c : Congruence α] : Con (FreeMonoid α) where + r := c.r + iseqv := c.iseqv + mul' {w x y z} h_wx h_yz := by + have h_wyxy : c.eq (w * y) (x * y) := c.right_cov.elim y h_wx + have h_xyxz : c.eq (x * y) (x * z) := c.left_cov.elim x h_yz + exact c.iseqv.trans h_wyxy h_xyxz + +/-- The syntactic monoid of a language `l` is the quotient of the free monoid +by the Myhill congruence of `l`. -/ +abbrev SyntacticMonoid (l : Language α) := l.MyhillCongruence.toCon.Quotient + +/-- A language `l` is regular if and only if its syntactic monoid is finite. -/ +theorem IsRegular.iff_finite_syntacticMonoid (l : Language α) : + l.IsRegular ↔ Finite (l.SyntacticMonoid) := + IsRegular.iff_finite_myhillQuotient l + +end Language diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean new file mode 100644 index 0000000000..6e0a104fe8 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/AlmostConstant.lean @@ -0,0 +1,393 @@ +/- +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 Mathlib.Data.List.Infix +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Complexity of Almost Constant Functions + +A function `f : α → β` that is constant except for a finite number of arguments is computable in +constant time and zero space: the machine reads the encoded input while remembering the prefix it +has seen so far. After a finite number of steps it either reaches the end of the input or a point +where the prefix cannot be extended to the encoding of one of the finitely many exceptions. In both +cases, it emits the corresponding output one symbol at a time. + +This result also holds for functions whose domain is already finite. + +## Main Results + +* `encodedComputableInTimeAndSpace_of_finite`: Every function on a finite type is computable in + constant time and zero space, relative to any encoding. +* `encodedComputableInTimeAndSpace_of_exists_finite_ne`: Every function that is constant except + for a finite number of arguments is computable in constant time and zero space, relative to any + encoding. +* `encodedComputableInTimeAndSpace_of_const`: Every constant function is computable in constant + time and zero space, relative to any encoding. +* `encodedComputableInTimeAndSpace_almostConstTime` and + `encodedComputableInTimeAndSpace_finiteFunTime`: The same with explicit time bounds. + +-/ + +namespace Turing.MultiTapeTM + +section AlmostConstFun + +/-! ## The machine computing a function that is constant outside a finite set + +The machine `almostConstTM encIn encOut f S out` computes `f`, provided that the encoded output +of `f` is the fixed Boolean string `out` outside of the finite set `S`. -/ + +variable {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {f : α → β} + {S : Finset α} {out : List Bool} + +/-- The prefixes of the encodings of the elements of a finite set `S`, together with the empty list. + +The empty list has to be added explicitly for the case where `S` is empty: `almostConstTM` uses +the elements of this set as its states while reading the input, so the set has to contain the +starting state `[]` even if there is nothing to distinguish. -/ +def encPrefixes (encIn : α ↪ List Bool) (S : Finset α) : Finset (List Bool) := + insert [] (S.biUnion fun a => (encIn a).inits.toFinset) + +lemma mem_encPrefixes {p : List Bool} {a : α} (ha : a ∈ S) (h : p <+: encIn a) : + p ∈ encPrefixes encIn S := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, List.mem_inits] + exact Or.inr ⟨a, ha, h⟩ + +/-- The set of prefixes is closed under taking prefixes. -/ +lemma prefix_mem_encPrefixes {p q : List Bool} (h : p ∈ encPrefixes encIn S) (hq : q <+: p) : + q ∈ encPrefixes encIn S := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, + List.mem_inits] at h ⊢ + rcases h with rfl | ⟨a, ha, hp⟩ + · exact Or.inl (List.prefix_nil.mp hq) + · exact Or.inr ⟨a, ha, hq.trans hp⟩ + +/-- The suffixes of the default output and of the encoded values of `f` on `S`. -/ +def outSuffixes (encOut : β ↪ List Bool) (f : α → β) (S : Finset α) (out : List Bool) : + Finset (List Bool) := + out.tails.toFinset ∪ S.biUnion fun a => (encOut (f a)).tails.toFinset + +lemma suffix_out_mem_outSuffixes {w : List Bool} (h : w <:+ out) : + w ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, List.mem_toFinset, List.mem_tails] + exact Or.inl h + +lemma mem_outSuffixes {w : List Bool} {a : α} (ha : a ∈ S) (h : w <:+ encOut (f a)) : + w ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, Finset.mem_biUnion, List.mem_toFinset, List.mem_tails] + exact Or.inr ⟨a, ha, h⟩ + +/-- The set of suffixes is closed under taking suffixes. -/ +lemma suffix_mem_outSuffixes {v w : List Bool} (h : w ∈ outSuffixes encOut f S out) (hv : v <:+ w) : + v ∈ outSuffixes encOut f S out := by + simp only [outSuffixes, Finset.mem_union, Finset.mem_biUnion, List.mem_toFinset, + List.mem_tails] at h ⊢ + rcases h with h | ⟨a, ha, h⟩ + · exact Or.inl (hv.trans h) + · exact Or.inr ⟨a, ha, hv.trans h⟩ + +lemma tail_mem_outSuffixes {w : List Bool} (h : w ∈ outSuffixes encOut f S out) : + w.tail ∈ outSuffixes encOut f S out := + suffix_mem_outSuffixes h (List.tail_suffix w) + +/-- If the encoded output is the default output outside of `S`, then every encoded output occurs +among the suffixes. -/ +lemma encOut_mem_outSuffixes (h : ∀ a ∉ S, encOut (f a) = out) (a : α) : + encOut (f a) ∈ outSuffixes encOut f S out := by + by_cases ha : a ∈ S + · exact mem_outSuffixes ha (List.suffix_refl _) + · rw [h a ha] + exact suffix_out_mem_outSuffixes (List.suffix_refl _) + +/-- The states of the machine `almostConstTM`: either the prefix of the input read so far, or the +part of the output that still has to be emitted. -/ +abbrev AlmostConstState (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : Type := + {p : List Bool // p ∈ encPrefixes encIn S} ⊕ {w : List Bool // w ∈ outSuffixes encOut f S out} + +open Classical in +/-- The function `f`, transported along the encodings of its domain and codomain: it maps the +encoding of an element of `S` to the encoding of its value under `f`, and every other list to the +default output. -/ +noncomputable def encodedFun (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) (p : List Bool) : List Bool := + if h : ∃ a ∈ S, encIn a = p then encOut (f h.choose) else out + +@[simp] +lemma encodedFun_enc {a : α} (ha : a ∈ S) : + encodedFun encIn encOut f S out (encIn a) = encOut (f a) := by + have hex : ∃ a' ∈ S, encIn a' = encIn a := ⟨a, ha, rfl⟩ + rw [encodedFun, dite_eq_left_of_eq_true (eq_true hex), encIn.injective hex.choose_spec.2] + +@[simp] +lemma encodedFun_enc_of_notMem {a : α} (ha : a ∉ S) : + encodedFun encIn encOut f S out (encIn a) = out := by + have hex : ¬ ∃ a' ∈ S, encIn a' = encIn a := by + rintro ⟨a', ha', h⟩ + exact ha (encIn.injective h ▸ ha') + rw [encodedFun, dite_eq_right_of_eq_false (eq_false hex)] + +lemma encodedFun_mem_outSuffixes (p : List Bool) : + encodedFun encIn encOut f S out p ∈ outSuffixes encOut f S out := by + rw [encodedFun] + split + · next h => exact mem_outSuffixes h.choose_spec.1 (List.suffix_refl _) + · exact suffix_out_mem_outSuffixes (List.suffix_refl _) + +open Classical in +/-- The machine computing a function that is constant outside of `S`. It has no work tapes. + +While reading the input it remembers the prefix read so far. Once this prefix cannot be extended +to the encoding of an element of `S` anymore, or the blank behind the input is reached, it +switches to the state that holds the encoded output, which it then emits one symbol per step +before halting. -/ +noncomputable def almostConstTM (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : + MultiTapeTM 0 Bool (AlmostConstState encIn encOut f S out) where + q₀ := Sum.inl ⟨[], by simp [encPrefixes]⟩ + tr q input _ := + match q with + | Sum.inl p => + match input with + | some b => + if h : p.val ++ [b] ∈ encPrefixes encIn S then + ⟨.pos, Fin.elim0, none, some (Sum.inl ⟨p.val ++ [b], h⟩)⟩ + else + ⟨0, Fin.elim0, none, + some (Sum.inr ⟨out, suffix_out_mem_outSuffixes (List.suffix_refl out)⟩)⟩ + | none => + ⟨0, Fin.elim0, none, + some (Sum.inr ⟨encodedFun encIn encOut f S out p.val, + encodedFun_mem_outSuffixes p.val⟩)⟩ + | Sum.inr w => + ⟨0, Fin.elim0, w.val.head?, + if w.val = [] then none + else some (Sum.inr ⟨w.val.tail, tail_mem_outSuffixes w.property⟩)⟩ + +/-- The configuration reached after `j` steps of reading the input. -/ +lemma runFrom_read (a : α) {j : ℕ} (hj : j ≤ (encIn a).length) + (hmem : (encIn a).take j ∈ encPrefixes encIn S) : + (almostConstTM encIn encOut f S out).runFrom + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) j = + { state := some (Sum.inl ⟨(encIn a).take j, hmem⟩), + inputPos := ⟨1 + j, by omega⟩, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := [] } := by + induction j with + | zero => + simp only [runFrom_zero, initCfg, List.take_zero] + ext <;> simp [almostConstTM] + | succ j ih => + have hprefix : (encIn a).take j <+: (encIn a).take (j + 1) := by + simp + have hmem' : (encIn a).take j ∈ encPrefixes encIn S := prefix_mem_encPrefixes hmem hprefix + have hcat : (encIn a).take j ++ [(encIn a)[j]] ∈ encPrefixes encIn S := by + grind [List.take_concat_get'] + have hmove : moveInputPos (⟨1 + j, by omega⟩ : Fin ((encIn a).length + 2)) SignType.pos + = ⟨1 + (j + 1), by omega⟩ := by + grind [moveInputPos_pos_of_ne_right] + have hstart : 1 + j ≠ 0 := by omega + have hend : 1 + j ≠ (encIn a).length + 1 := by omega + have hprev : 1 + j - 1 = j := by omega + rw [runFrom_succ_eq_step', ih (by omega) hmem'] + simp only [step, Action.apply, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, + hstart, hend, hprev, reduceDIte, hcat] + exact Cfg.ext_zero_tapes (by grind [List.take_concat_get']) hmove (by simp) + +/-- The configuration reached after having emitted the first `i` symbols of `w`, starting from a +configuration that is about to emit `w`. -/ +lemma runFrom_write {input : List Bool} (pos : Fin (input.length + 2)) (o : List Bool) + {w : List Bool} (hw : w ∈ outSuffixes encOut f S out) {i : ℕ} (hi : i ≤ w.length) : + (almostConstTM encIn encOut f S out).runFrom + { state := some (Sum.inr ⟨w, hw⟩), inputPos := pos, workTapes := fun _ _ => none, + workTapePos := fun _ => 0, output := o } i = + { state := some (Sum.inr ⟨w.drop i, suffix_mem_outSuffixes hw (w.drop_suffix i)⟩), + inputPos := pos, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := o ++ w.take i } := by + induction i with + | zero => simp [runFrom_zero] + | succ i ih => + have hilt : i < w.length := by omega + have htake := List.take_concat_get' w i hilt + have hnotdone : ¬ (w.length ≤ i) := by omega + rw [runFrom_succ_eq_step', ih (by omega)] + simp only [step, Action.apply, almostConstTM, List.head?_drop, + List.getElem?_eq_getElem hilt, List.drop_eq_nil_iff, hnotdone, reduceIte, List.tail_drop, + moveInputPos_zero, Option.toList_some] + exact Cfg.ext_zero_tapes rfl rfl (by grind) + +/-- Starting from a configuration that is about to emit `w`, the machine halts after `w.length + 1` +steps, having emitted `w`. -/ +lemma runFrom_write_halted {input : List Bool} (pos : Fin (input.length + 2)) (o : List Bool) + {w : List Bool} (hw : w ∈ outSuffixes encOut f S out) : + (almostConstTM encIn encOut f S out).runFrom + { state := some (Sum.inr ⟨w, hw⟩), inputPos := pos, workTapes := fun _ _ => none, + workTapePos := fun _ => 0, output := o } (w.length + 1) = + { state := none, + inputPos := pos, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := o ++ w } := by + rw [runFrom_succ_eq_step', runFrom_write pos o hw le_rfl] + simp only [step, Action.apply, almostConstTM, List.drop_length, reduceIte, List.head?_nil, + moveInputPos_zero, Option.toList_none, List.append_nil, List.take_length] + exact Cfg.ext_zero_tapes rfl rfl (by simp) + +/-- A constant time bound for the machine `almostConstTM`. -/ +@[expose] +public def almostConstTime (encIn : α ↪ List Bool) (encOut : β ↪ List Bool) (f : α → β) + (S : Finset α) (out : List Bool) : ℕ := + 2 + out.length + S.sup fun a => (encIn a).length + (encOut (f a)).length + +lemma length_le_sup_of_mem_encPrefixes {p : List Bool} (h : p ∈ encPrefixes encIn S) : + p.length ≤ S.sup fun a => (encIn a).length + (encOut (f a)).length := by + simp only [encPrefixes, Finset.mem_insert, Finset.mem_biUnion, List.mem_toFinset, + List.mem_inits] at h + rcases h with rfl | ⟨a, ha, hp⟩ + · simp + · have hsup : (encIn a).length + (encOut (f a)).length ≤ + S.sup fun a => (encIn a).length + (encOut (f a)).length := + Finset.le_sup (f := fun a => (encIn a).length + (encOut (f a)).length) ha + have := hp.length_le + omega + +/-- The machine reaches the state in which it starts emitting the encoded output after a number +of steps that is bounded independently of the input. -/ +lemma reaches_write (h : ∀ a ∉ S, encOut (f a) = out) (a : α) : + ∃ (j : ℕ) (hj : j ≤ (encIn a).length), + j + (encOut (f a)).length ≤ + out.length + S.sup (fun a => (encIn a).length + (encOut (f a)).length) ∧ + (almostConstTM encIn encOut f S out).runFrom + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) (j + 1) = + { state := some (Sum.inr ⟨encOut (f a), encOut_mem_outSuffixes h a⟩), + inputPos := ⟨1 + j, by omega⟩, + workTapes := fun _ _ => none, + workTapePos := fun _ => 0, + output := [] } := by + classical + set j := Nat.findGreatest (fun j => (encIn a).take j ∈ encPrefixes encIn S) (encIn a).length + with hjdef + have hmem : (encIn a).take j ∈ encPrefixes encIn S := + Nat.findGreatest_spec (P := fun j => (encIn a).take j ∈ encPrefixes encIn S) + (Nat.zero_le _) (by simp [encPrefixes]) + have hjle : j ≤ (encIn a).length := Nat.findGreatest_le _ + have hjsup : j ≤ S.sup fun a => (encIn a).length + (encOut (f a)).length := by + have hlen := length_le_sup_of_mem_encPrefixes (encOut := encOut) (f := f) hmem + rw [List.length_take] at hlen + omega + use j, hjle + constructor + · by_cases ha : a ∈ S + · grind [Finset.le_sup (f := fun a => (encIn a).length + (encOut (f a)).length) ha] + · grind [h a ha] + rw [runFrom_succ_eq_step', runFrom_read a hjle hmem] + rcases eq_or_lt_of_le hjle with heq | hlt + · -- the whole input has been read, so the machine decodes it + have hend : 1 + j = (encIn a).length + 1 := by omega + have hdec : encodedFun encIn encOut f S out ((encIn a).take j) = encOut (f a) := by + rw [heq, List.take_length] + by_cases ha : a ∈ S + · exact encodedFun_enc ha + · rw [encodedFun_enc_of_notMem ha, h a ha] + simp only [step, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, hend, + reduceDIte, dite_eq_ite, ite_self, hdec] + exact Cfg.ext_zero_tapes rfl (by simp) (by simp) + · -- the prefix read so far cannot be extended, so the machine emits the default output + have hend : 1 + j ≠ (encIn a).length + 1 := by omega + have hprev : 1 + j - 1 = j := by omega + have hnotmem : (encIn a).take (j + 1) ∉ encPrefixes encIn S := + Nat.findGreatest_is_greatest (hjdef ▸ Nat.lt_succ_self j) (by omega) + have hcat : (encIn a).take j ++ [(encIn a)[j]] ∉ encPrefixes encIn S := by + grind [List.take_concat_get'] + have ha : a ∉ S := fun ha => hnotmem (mem_encPrefixes ha ((encIn a).take_prefix _)) + have hstart : 1 + j ≠ 0 := by omega + simp only [step, Action.apply, almostConstTM, Cfg.inputSymbol, Fin.ext_iff, Fin.val_zero, + hstart, hend, hprev, reduceDIte, hcat, moveInputPos_zero] + refine Cfg.ext_zero_tapes ?_ (by simp) (by simp) + simp only [Option.some.injEq, Sum.inr.injEq, Subtype.mk.injEq] + exact (h a ha).symm + +/-- The machine `almostConstTM` computes `f` in at most `almostConstTime` steps and no space. -/ +lemma computesFunInTimeAndSpace_almostConstTM (h : ∀ a ∉ S, encOut (f a) = out) : + ComputesFunInTimeAndSpace (almostConstTM encIn encOut f S out) encIn encOut f + (fun _ => almostConstTime encIn encOut f S out) (fun _ => 0) := by + intro a + obtain ⟨j, hjle, hj, hrun⟩ := reaches_write h a + have hhalt := (almostConstTM encIn encOut f S out).runFrom_add + ((almostConstTM encIn encOut f S out).initCfg (encIn a)) (j + 1) ((encOut (f a)).length + 1) + rw [hrun, runFrom_write_halted] at hhalt + use j + 1 + ((encOut (f a)).length + 1) + refine ⟨?_, 0, le_rfl, ?_⟩ + · change j + 1 + ((encOut (f a)).length + 1) ≤ almostConstTime encIn encOut f S out + rw [almostConstTime] + omega + · unfold ComputesInTimeAndSpace + rw [hhalt] + simp + +end AlmostConstFun + +section Results + +variable {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + +/-- Every function whose encoded output is constant outside of a finite set is computable in time +`almostConstTime` and zero space. -/ +public theorem computableInTimeAndSpace_almostConstTime + (f : α → β) (S : Finset α) (out : List Bool) (h : ∀ a ∉ S, encOut (f a) = out) : + ComputableInTimeAndSpace f encIn encOut + (fun _ => almostConstTime encIn encOut f S out) (fun _ => 0) := + ⟨0, AlmostConstState encIn encOut f S out, inferInstance, almostConstTM encIn encOut f S out, + computesFunInTimeAndSpace_almostConstTM h⟩ + +/-- Every almost constant function is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_exists_finite_ne + {f : α → β} (h : ∃ b : β, {a : α | f a ≠ b}.Finite) : + ∃ c, ComputableInTimeAndSpace f encIn encOut (fun _ => c) (fun _ => 0) := by + obtain ⟨b, hb⟩ := h + refine ⟨_, computableInTimeAndSpace_almostConstTime f hb.toFinset (encOut b) ?_⟩ + intro a ha + simp only [Set.Finite.mem_toFinset, Set.mem_ofPred_eq, not_not] at ha + rw [ha] + +/-- Every constant function is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_const {α β : Type*} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} (b : β) : + ∃ c, ComputableInTimeAndSpace (Function.const α b) encIn encOut + (fun _ => c) (fun _ => 0) := + computableInTimeAndSpace_of_exists_finite_ne ⟨b, by simp⟩ + +/-- A constant time bound for functions on a finite type. -/ +@[expose] +public noncomputable def finiteFunTime {α β : Type*} [Finite α] (encIn : α ↪ List Bool) + (encOut : β ↪ List Bool) (f : α → β) : ℕ := + haveI := Fintype.ofFinite α + almostConstTime encIn encOut f Finset.univ [] + +/-- Every function on a finite type is computable in time `finiteFunTime` and zero space. -/ +public theorem computableInTimeAndSpace_finiteFunTime {α β : Type*} [Finite α] + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} (f : α → β) : + ComputableInTimeAndSpace f encIn encOut + (fun _ => finiteFunTime encIn encOut f) (fun _ => 0) := + computableInTimeAndSpace_almostConstTime f (@Finset.univ α (Fintype.ofFinite α)) [] + fun a ha => absurd (@Finset.mem_univ α (Fintype.ofFinite α) a) ha + +/-- Every function on a finite type is computable in constant time and zero space. -/ +public theorem computableInTimeAndSpace_of_finite {α β : Type*} [Finite α] + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + (f : α → β) : + ∃ c, ComputableInTimeAndSpace f encIn encOut (fun _ => c) (fun _ => 0) := + ⟨_, computableInTimeAndSpace_finiteFunTime f⟩ + +end Results + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Comp.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Comp.lean new file mode 100644 index 0000000000..435f81c66d --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Comp.lean @@ -0,0 +1,123 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters + +/-! +# Complexity of function composition + +If `f` and `gg` are computable in time and space, then so is `gg ∘ f`. The two function machines are +placed by the general tape-transformer adapters on a shared work-tape layout — `f` reads the real +input and writes a scratch tape, `gg` reads that tape and writes another — and the result is emitted +as the output. All the tape bookkeeping is hidden inside the adapters, so the proof only has to name +the single handoff tape between the two machines. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_comp`: the complexity of `gg ∘ f`. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α β γ : Type*} + +/-- **Complexity of a composition.** If `f` and `gg` are computable, so is `gg ∘ f`. The two +function machines are placed by the general adapters on a shared layout: `f` reads the real input +and writes tape `o1`, `gg` reads `o1` and writes tape `o`, and the result is emitted from `o`. All +the tape bookkeeping is hidden inside `exists_transformsTapes_ofComputable{,Input}`; here only the +handoff `o1` between the two machines and the final emit remain. -/ +public theorem computableInTimeAndSpace_comp + {f : α → β} {gg : β → γ} {encA : α ↪ List Bool} {encB : β ↪ List Bool} {encC : γ ↪ List Bool} + {tf sf : α → ℕ} {tg sg : β → ℕ} + (hf : ComputableInTimeAndSpace f encA encB tf sf) + (hg : ComputableInTimeAndSpace gg encB encC tg sg) : + ∃ c, ComputableInTimeAndSpace (gg ∘ f) encA encC + (fun a => c * (tf a + tg (f a) + (encB (f a)).length + 1)) + (fun a => c * (sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1)) := by + classical + -- `f` reads the real input and leaves `encB (f a)` on tape `o1`; `gg` reads `o1` and leaves + -- `encC (gg x)` on tape `o`. The general adapters hide their scratch tapes. + obtain ⟨m_f, c_f, hf'⟩ := exists_transformsTapes_ofComputableInput hf + obtain ⟨m_g, c_g, hg'⟩ := exists_transformsTapes_ofComputable hg + set k := m_f + m_g + 2 with hk + let o1 : Fin k := ⟨0, by omega⟩ + let o : Fin k := ⟨1, by omega⟩ + have ho1o : o1 ≠ o := by + apply Fin.ne_of_val_ne; simp + obtain ⟨S_f, hS_f, M_f, hM_f⟩ := + hf' k o1 ∅ (by simp) (by simp only [Finset.card_empty]; omega) + obtain ⟨S_g, hS_g, M_g, hM_g⟩ := + hg' k o1 o ∅ ho1o (by simp) (by simp) (by simp only [Finset.card_empty]; omega) + have hfin_f := hS_f + have hfin_g := hS_g + -- The composite tape transformer: run `M_f`, then `M_g` reading `M_f`'s output tape `o1`. + have hMc : ∀ a, TransformsTapes (M_f.seq M_g) + (fun input ws => input = encA a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' o = encC (gg (f a))) + (c_f * (tf a + 1) + c_g * (tg (f a) + 1)) + ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k)) := by + intro a + refine (transformsTapes_seq (h₀ := hM_f a) (h₁ := hM_g (f a)) ?_).imp ?_ ?_ le_rfl le_rfl + · -- handoff: after `M_f`, `M_g`'s precondition holds on tape `o1` + rintro input ws ws' ⟨rfl, hblank⟩ hQf + refine ⟨?_, ?_⟩ + · rw [hQf, Function.update_self] + · intro l hl _ + rw [hQf, Function.update_of_ne hl] + exact hblank l (by simp) + · -- precondition: an all-blank input satisfies `M_f`'s (empty-`keep`) precondition + rintro input ws ⟨rfl, hblank⟩ + exact ⟨rfl, fun l _ => hblank l⟩ + · -- postcondition: read the result off `M_g`'s output tape `o` + rintro input ws ws'' _ ⟨ws', _, hQg⟩ + rw [hQg, Function.update_self] + -- Emit tape `o` as the real output, turning the transformer into a computation. + obtain ⟨c, hc⟩ := + computableInTimeAndSpace_of_transformsTapes (gg := gg ∘ f) o hMc + -- Relax the bounds to the stated linear form. + refine ⟨c * (c_f + c_g + 2 * k + 2), hc.mono (fun a => ?_) (fun a => ?_)⟩ + · -- Time. + have hlc : (encC (gg (f a))).length ≤ tg (f a) := hg.length_encOut_le (f a) + set T := tf a + tg (f a) + (encB (f a)).length + 1 with hT + have e1 : c_f * (tf a + 1) ≤ c_f * T := Nat.mul_le_mul_left _ (by omega) + have e2 : c_g * (tg (f a) + 1) ≤ c_g * T := Nat.mul_le_mul_left _ (by omega) + have hexp : (c_f + c_g + 2 * k + 2) * T = + c_f * T + c_g * T + 2 * k * T + 2 * T := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have e4 : (encC (gg (f a))).length + 1 ≤ 2 * T := by omega + have hmul : c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * T) := Nat.mul_le_mul_left _ (by omega) + calc c * (c_f * (tf a + 1) + c_g * (tg (f a) + 1) + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * T) := hmul + _ = c * (c_f + c_g + 2 * k + 2) * T := (Nat.mul_assoc _ _ _).symm + · -- Space. + set PS := sf a + sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1 with hPS + have f1 : c_f * (sf a + (encB (f a)).length + 1) ≤ c_f * PS := + Nat.mul_le_mul_left _ (by omega) + have f2 : c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) ≤ c_g * PS := + Nat.mul_le_mul_left _ (by omega) + have q1 : 2 * k ≤ 2 * k * PS := Nat.le_mul_of_pos_right _ (by omega) + have e4 : (encC (gg (f a))).length + 1 ≤ 2 * PS := by omega + have hexpS : (c_f + c_g + 2 * k + 2) * PS = + c_f * PS + c_g * PS + 2 * k * PS + 2 * PS := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have hmul : c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := Nat.mul_le_mul_left _ (by omega) + calc c * ((c_f * (sf a + (encB (f a)).length + 1) + k) + + (c_g * (sg (f a) + (encB (f a)).length + (encC (gg (f a))).length + 1) + k) + + (encC (gg (f a))).length + 1) + ≤ c * ((c_f + c_g + 2 * k + 2) * PS) := hmul + _ = c * (c_f + c_g + 2 * k + 2) * PS := (Nat.mul_assoc _ _ _).symm + + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean new file mode 100644 index 0000000000..d72f721030 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Id.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Complexity of the identity function + +A machine with a single state and no work tapes scans the input from left to right, copying each +symbol to the output tape, and halts on the blank at the right end of the input. On input `w` it +outputs `w` after `w.length + 1` steps, and having no work tapes it uses zero space. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_id`: the identity is computable in one step per + input symbol and zero space. +-/ + +namespace Turing.MultiTapeTM + +variable {Symbol : Type*} {input : List Symbol} + +/-- The copy machine: a single state and no work tapes. It copies every input symbol to the output +tape while moving right, and halts on reading the blank at the right end of the input. -/ +def copy : MultiTapeTM 0 Symbol Unit where + q₀ := () + tr _ s _ := + match s with + | some b => { inputTape := 1, workTapes := fun i => i.elim0, output := some b, + state := some () } + | none => { inputTape := 0, workTapes := fun i => i.elim0, output := none, state := none } + +namespace Copy + +/-- A configuration of the copy machine, given by the input, the control state, the input head +position and the output written so far. There are no work tapes. `input` is explicit because it is +inferable only through the expected type: the head position is written as an anonymous +constructor, which pins nothing. -/ +def cfg (input : List Symbol) (q : Option Unit) (p : Fin (input.length + 2)) + (out : List Symbol) : Cfg 0 Symbol Unit input := + ⟨q, p, fun _ _ => none, fun _ => 0, out⟩ + +/-- Over an input symbol, the copy machine emits it and moves right. -/ +lemma step_scan {n : ℕ} (hn : n < input.length) (out : List Symbol) : + copy.step (cfg input (some ()) ⟨n + 1, by omega⟩ out) = + cfg input (some ()) ⟨n + 2, by omega⟩ (out ++ [input[n]]) := by + have hsym : (cfg input (some ()) ⟨n + 1, by omega⟩ out).inputSymbol = + some input[n] := inputSymbolInner n (by simp only [cfg]; omega) hn + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + refine Cfg.ext_zero_tapes rfl ?_ rfl + apply Fin.ext + simp [copy, Action.apply, moveInputPos] + grind + +/-- On the blank at the right end of the input, the copy machine halts in place. -/ +lemma step_halt (out : List Symbol) : + copy.step (cfg input (some ()) ⟨input.length + 1, by omega⟩ out) = + cfg input none ⟨input.length + 1, by omega⟩ out := by + have hsym : (cfg input (some ()) ⟨input.length + 1, by omega⟩ out).inputSymbol = + none := + inputSymbol_eq_none_of_boundary (Or.inr rfl) + unfold step + simp only [cfg] at hsym ⊢ + rw [hsym] + exact Cfg.ext_zero_tapes rfl (by simp [copy, Action.apply]) (by simp [copy, Action.apply]) + +/-- After `n ≤ input.length` steps, the copy machine has copied the first `n` input symbols to the +output and its head is over the `n`-th cell of the input. -/ +lemma runFrom_scan (n : ℕ) (hn : n ≤ input.length) : + copy.runFrom (copy.initCfg input) n = + cfg input (some ()) ⟨n + 1, by omega⟩ (input.take n) := by + induction n with + | zero => exact Cfg.ext_zero_tapes rfl rfl rfl + | succ n ih => + rw [runFrom_succ_eq_step', ih (by omega), step_scan (by omega)] + have htake : input.take n ++ [input[n]] = input.take (n + 1) := by + rw [List.take_add_one, List.getElem?_eq_getElem (by omega), Option.toList_some] + rw [htake] + +/-- The complete run: after `input.length + 1` steps the copy machine has halted with the input +copied to the output. -/ +lemma runFrom_full (input : List Symbol) : + copy.runFrom (copy.initCfg input) (input.length + 1) = + cfg input none ⟨input.length + 1, by omega⟩ input := by + rw [runFrom_succ_eq_step', runFrom_scan input.length le_rfl, List.take_length, step_halt] + +/-- The copy machine outputs its input unchanged, in `input.length + 1` steps and zero space. -/ +theorem computesInTimeAndSpace (input : List Symbol) : + ComputesInTimeAndSpace copy input input (input.length + 1) 0 := + ⟨by rw [runFrom_full]; rfl, by rw [runFrom_full]; rfl, + copy.spaceUsed_zero_tapes_eq_zero _ _ rfl⟩ + +end Copy + +variable {α : Type*} + +/-- The identity function is computable in one step per input symbol and zero space. -/ +public theorem computableInTimeAndSpace_id {enc : α ↪ List Bool} : + ComputableInTimeAndSpace (id : α → α) enc enc + (fun a => (enc a).length + 1) (fun _ => 0) := + ⟨0, Unit, inferInstance, copy, fun a => + ⟨(enc a).length + 1, le_rfl, 0, le_rfl, Copy.computesInTimeAndSpace (enc a)⟩⟩ + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean new file mode 100644 index 0000000000..0439a5636a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Ite.lean @@ -0,0 +1,462 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Comp +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters + +/-! +# Complexity of a case analysis + +A case analysis chooses which of several machines to continue with. `cond` is built directly on the +general tape-transformer machinery: the selector and the two branches enter the transformer +interface through `exists_transformsTapes_ofComputableInput`, and `exists_transformsTapes_branch` +dispatches on the selector's bit. `ite`, `dite` and the finite `match` are then read off `cond`. + +## Why the branch not taken is never run + +The dispatch reads the selector bit that the selector machine has left on a work tape and, in one +step, jumps to the `then`-arm or the `else`-arm; only that arm runs, and it emits its result +*straight to the shared output tape*. Only one arm ever runs, and its result is never parked to be +copied out — so nesting `n` conditionals runs `n` arms, not `2 ^ n`. This laziness is the content of +a case analysis, and it cannot come from composing total functions (`cond ∘ (fun a => (c a, f a, +g a))` would compute every branch), which is why one machine-level branch is unavoidable. + +## From `cond` to `ite`, `dite` and `match` + +`ite` and `dite` are `cond` read through `decide`; the finite `match` is a `Finset` induction that +splices in one `cond` per case. + +## Bounds + +Bounds here are deliberately relaxed to a single combined shape, `c * (… + 1)`, collecting the +shared time and space bounds and the input length: nothing downstream depends on the conditional +family being tight (`loop` and `comp` do not use it), and the construction spends constant factors +freely. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_match`: a case analysis on a scrutinee in a finite + type. See `CslibTests.Complexity.Combinators` for worked examples. +* `Turing.MultiTapeTM.computableInTimeAndSpace_cond`: the recursor of `Bool`. +* `Turing.MultiTapeTM.computableInTimeAndSpace_ite`: Lean's `ite`, for a decidable predicate. +* `Turing.MultiTapeTM.computableInTimeAndSpace_dite`: Lean's `dite`, whose branches are defined + only under a hypothesis and so are supplied through total extensions. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α β : Type*} + +/-- The single-symbol encoding of a Boolean: `true`/`false` become the one-element words `[true]`, +`[false]`. Branching on a tape holding `boolEnc b` reads `b` directly as the head symbol, so the +dispatch of a two-way case analysis is a single-symbol read. -/ +public def boolEnc : Bool ↪ List Bool := ⟨fun b => [b], by intro a b h; simpa using h⟩ + +@[simp] public lemma boolEnc_apply (b : Bool) : boolEnc b = [b] := rfl + +/-- **Complexity of a two-way case analysis**, the recursor of `Bool`. If the scrutinee and both +branches are computable, then so is the case analysis `bif sel a then g a else h a`. + +The construction reuses the general tape-transformer machinery. The selector, the `then`-branch +and the `else`-branch are each placed on a shared work-tape layout by +`exists_transformsTapes_ofComputableInput`: the selector leaves its single bit `boolEnc (sel a)` on +tape `c`, and each branch reads the real input and leaves its encoded result on the shared output +tape `o` (treating `c` as a tape to keep). `exists_transformsTapes_branch` on tape `c` then runs the +`then`-branch when that bit is `true` and the `else`-branch otherwise — the two arms share the +postcondition "`o` holds `encOut (bif sel a then g a else h a)`", each arm supplying the case +(`sel a = true` / `sel a = false`) that identifies its result with it. Sequencing the selector +before the branch and emitting tape `o` (`computableInTimeAndSpace_of_transformsTapes`) reads off +the case analysis. Bounds are relaxed to the single combined shape `c * (… + 1)`; nothing +downstream needs them tight. -/ +public theorem computableInTimeAndSpace_cond {sel : α → Bool} {g h : α → β} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {t s : α → ℕ} + (hsel : ComputableInTimeAndSpace sel encIn boolEnc t s) + (hif : ComputableInTimeAndSpace g encIn encOut t s) + (helse : ComputableInTimeAndSpace h encIn encOut t s) : + ∃ c, ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + classical + -- the three function machines, placed on a shared layout by the general adapters + obtain ⟨m_sel, c_sel, hsel'⟩ := exists_transformsTapes_ofComputableInput hsel + obtain ⟨m_g, c_g, hif'⟩ := exists_transformsTapes_ofComputableInput hif + obtain ⟨m_h, c_h, helse'⟩ := exists_transformsTapes_ofComputableInput helse + set k := m_sel + m_g + m_h + 3 with hk + let c : Fin k := ⟨0, by omega⟩ + let o : Fin k := ⟨1, by omega⟩ + have hoc : o ≠ c := by apply Fin.ne_of_val_ne; simp + -- `M_sel` writes the selector bit to tape `c`; `M_g`/`M_h` read the input, keep `c`, write to `o` + obtain ⟨S_sel, hS_sel, M_sel, hM_sel⟩ := + hsel' k c ∅ (by simp) (by simp only [Finset.card_empty]; omega) + obtain ⟨S_g, hS_g, M_g, hM_g⟩ := + hif' k o {c} (by simpa using hoc) (by simp only [Finset.card_singleton]; omega) + obtain ⟨S_h, hS_h, M_h, hM_h⟩ := + helse' k o {c} (by simpa using hoc) (by simp only [Finset.card_singleton]; omega) + have := hS_sel; have := hS_g; have := hS_h + have hleg : ∀ a, (encOut (g a)).length ≤ t a := hif.length_encOut_le + have hleh : ∀ a, (encOut (h a)).length ≤ t a := helse.length_encOut_le + -- arm 1: run `g`, guarded by `sel a = true`, its result identified with the case analysis + have h₁ : ∀ a, TransformsTapes M_g + (fun input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = true) + (fun _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) + (c_g * (t a + 1)) (c_g * (s a + (encOut (g a)).length + 1) + k) := by + intro a + refine (hM_g a).imp (fun _ _ hP => hP.1) (fun _ _ ws' hP hQ => ?_) le_rfl le_rfl + rw [hQ]; simp only [hP.2, Bool.cond_true] + -- arm 2: run `h`, guarded by `sel a = false` + have h₂ : ∀ a, TransformsTapes M_h + (fun input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = false) + (fun _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) + (c_h * (t a + 1)) (c_h * (s a + (encOut (h a)).length + 1) + k) := by + intro a + refine (hM_h a).imp (fun _ _ hP => hP.1) (fun _ _ ws' hP hQ => ?_) le_rfl le_rfl + rw [hQ]; simp only [hP.2, Bool.cond_false] + -- branch on the selector bit on tape `c` + obtain ⟨S_br, hS_br, M_br, hM_br⟩ := + exists_transformsTapes_branch (J := α) c true + (P₁ := fun a input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = true) + (P₂ := fun a input ws => (input = encIn a ∧ ∀ l, l ∉ ({c} : Finset (Fin k)) → ws l = []) + ∧ sel a = false) + (Q := fun a _ ws ws' => ws' = Function.update ws o (encOut (bif sel a then g a else h a))) + (t₁ := fun a => c_g * (t a + 1)) + (s₁ := fun a => c_g * (s a + (encOut (g a)).length + 1) + k) + (t₂ := fun a => c_h * (t a + 1)) + (s₂ := fun a => c_h * (s a + (encOut (h a)).length + 1) + k) h₁ h₂ + have := hS_br + -- run the selector, then the branch, as a single tape transformer emitting `o` + have hMc : ∀ a, TransformsTapes (M_sel.seq M_br) + (fun input ws => input = encIn a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' o = encOut (bif sel a then g a else h a)) + (c_sel * (t a + 1) + (max (c_g * (t a + 1)) (c_h * (t a + 1)) + 1)) + (c_sel * (s a + (boolEnc (sel a)).length + 1) + k + + (max (c_g * (s a + (encOut (g a)).length + 1) + k) + (c_h * (s a + (encOut (h a)).length + 1) + k) + k)) := by + intro a + refine (transformsTapes_seq (hM_sel a) (hM_br a) ?_).imp ?_ ?_ le_rfl le_rfl + · -- handoff: after the selector, the branch precondition holds + rintro _ ws ws' ⟨rfl, hblank⟩ hQsel + have hchead : (ws' c).head? = some (sel a) := by rw [hQsel, Function.update_self]; simp + have hbl : ∀ l, l ∉ ({c} : Finset (Fin k)) → ws' l = [] := fun l hl => by + rw [hQsel, Function.update_of_ne (by simpa using hl)]; exact hblank l (by simp) + split + · rename_i hcond + rw [hchead] at hcond + exact ⟨⟨rfl, hbl⟩, Option.some.inj hcond⟩ + · rename_i hcond + rw [hchead] at hcond + refine ⟨⟨rfl, hbl⟩, ?_⟩ + rw [← Bool.not_eq_true] + exact fun h => hcond (by rw [h]) + · -- an all-blank input satisfies the selector's precondition + rintro _ ws ⟨rfl, hblank⟩ + exact ⟨rfl, fun l _ => hblank l⟩ + · -- read the result off the output tape + rintro _ ws ws'' _ ⟨ws', _, hQbr⟩ + rw [hQbr, Function.update_self] + -- emit tape `o`, turning the transformer into a computation + obtain ⟨c₀, hc₀⟩ := + computableInTimeAndSpace_of_transformsTapes (gg := fun a => bif sel a then g a else h a) o hMc + refine ⟨c₀ * (2 * c_sel + c_g + c_h + 3 * k + 3), hc₀.mono (fun a => ?_) (fun a => ?_)⟩ + · -- time + set U := t a + s a + (encIn a).length + 1 with hU + have hlen : (encOut (bif sel a then g a else h a)).length ≤ U := by + have := hleg a; have := hleh a + cases sel a <;> simp only [Bool.cond_true, Bool.cond_false] <;> omega + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left c₀ ?_ + have e_sel : c_sel * (t a + 1) ≤ c_sel * U := Nat.mul_le_mul_left _ (by omega) + have e_g : c_g * (t a + 1) ≤ c_g * U := Nat.mul_le_mul_left _ (by omega) + have e_h : c_h * (t a + 1) ≤ c_h * U := Nat.mul_le_mul_left _ (by omega) + have hexp : (2 * c_sel + c_g + c_h + 3 * k + 3) * U + = 2 * (c_sel * U) + c_g * U + c_h * U + 3 * (k * U) + 3 * U := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] + omega + · -- space + set U := t a + s a + (encIn a).length + 1 with hU + have hlen : (encOut (bif sel a then g a else h a)).length ≤ U := by + have := hleg a; have := hleh a + cases sel a <;> simp only [Bool.cond_true, Bool.cond_false] <;> omega + rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left c₀ ?_ + have hkU : k ≤ k * U := Nat.le_mul_of_pos_right k (by omega) + have e_sel : c_sel * (s a + (boolEnc (sel a)).length + 1) ≤ 2 * (c_sel * U) := by + have h1 : (boolEnc (sel a)).length = 1 := by simp + calc c_sel * (s a + (boolEnc (sel a)).length + 1) + ≤ c_sel * (2 * U) := Nat.mul_le_mul_left _ (by rw [h1]; omega) + _ = 2 * (c_sel * U) := by rw [Nat.mul_left_comm] + have e_g : c_g * (s a + (encOut (g a)).length + 1) ≤ c_g * U := + Nat.mul_le_mul_left _ (by have := hleg a; omega) + have e_h : c_h * (s a + (encOut (h a)).length + 1) ≤ c_h * U := + Nat.mul_le_mul_left _ (by have := hleh a; omega) + have hexp : (2 * c_sel + c_g + c_h + 3 * k + 3) * U + = 2 * (c_sel * U) + c_g * U + c_h * U + 3 * (k * U) + 3 * U := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.add_mul, Nat.mul_assoc, Nat.mul_assoc] + omega + +/-! ### The finite case analysis + +The finite case analysis is built from `computableInTimeAndSpace_cond` by induction on a finite +set covering the scrutinee's reachable values. Because each inductive step splices in one more +`cond`, whose constants multiply, the bounds are renormalised at every step into the single fixed +shape `fun a => c * (t a + 1)`, `fun a => c * (s a + 1)`; the following three helpers do the +combining and the renormalisation, and the induction then reduces to routing the scrutinee. -/ + +variable {t s : α → ℕ} {encIn : α ↪ List Bool} + +/-- A constant function, in the normalised bound shape `c * (t a + s a + (encIn a).length + 1)`. -/ +private lemma const_norm {encOut : β ↪ List Bool} (b : β) : + ∃ c, ComputableInTimeAndSpace (fun _ : α => b) encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + obtain ⟨c, hc⟩ := computableInTimeAndSpace_of_const (encIn := encIn) (encOut := encOut) b + exact ⟨c, hc.mono (fun a => Nat.le_mul_of_pos_right c (by omega)) (fun a => Nat.zero_le _)⟩ + +/-- A two-way case analysis of three functions all given in the normalised shape stays in it. The +new `cond` bound mixes each argument's time *and* space bounds and adds the input length, but every +one of those is a constant times `t a + s a + (encIn a).length + 1`, so the shape is preserved. -/ +private lemma cond_norm {sel : α → Bool} {g h : α → β} {encOut : β ↪ List Bool} + (hsel : ∃ c, ComputableInTimeAndSpace sel encIn boolEnc + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) + (hg : ∃ c, ComputableInTimeAndSpace g encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) + (hh : ∃ c, ComputableInTimeAndSpace h encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) : + ∃ c, ComputableInTimeAndSpace (fun a => bif sel a then g a else h a) encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + obtain ⟨c1, h1⟩ := hsel + obtain ⟨c2, h2⟩ := hg + obtain ⟨c3, h3⟩ := hh + set C₀ := c1 + c2 + c3 with hC₀ + -- weaken the three inputs to the common bound `C₀ * (t + s + L + 1)` + have hmono : ∀ (c' : ℕ), c' ≤ C₀ → ∀ a, + c' * (t a + s a + (encIn a).length + 1) ≤ C₀ * (t a + s a + (encIn a).length + 1) := + fun _ hc' a => Nat.mul_le_mul_right _ hc' + have h1' : ComputableInTimeAndSpace sel encIn boolEnc + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) := + h1.mono (hmono c1 (by omega)) (hmono c1 (by omega)) + have h2' : ComputableInTimeAndSpace g encIn encOut + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) := + h2.mono (hmono c2 (by omega)) (hmono c2 (by omega)) + have h3' : ComputableInTimeAndSpace h encIn encOut + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) + (fun a => C₀ * (t a + s a + (encIn a).length + 1)) := + h3.mono (hmono c3 (by omega)) (hmono c3 (by omega)) + obtain ⟨C, hC⟩ := computableInTimeAndSpace_cond h1' h2' h3' + refine ⟨C * (2 * C₀ + 1), hC.mono (fun a => ?_) (fun a => ?_)⟩ <;> + · rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left C ?_ + have hexp : (2 * C₀ + 1) * (t a + s a + (encIn a).length + 1) = + 2 * (C₀ * (t a + s a + (encIn a).length + 1)) + (t a + s a + (encIn a).length + 1) := by + rw [Nat.add_mul, Nat.mul_assoc, Nat.one_mul] + omega + +/-- The single-bit test `decide (sel a = i₀)`, in the normalised shape. Composing the scrutinee with +the almost-constant test `· = i₀` is a `computableInTimeAndSpace_comp`; the constant test cost and +the encoded scrutinee's length are absorbed because the latter is bounded by the constant `L`. -/ +private lemma cond_of_sel {ι : Type} [DecidableEq ι] {sel : α → ι} {encι : ι ↪ List Bool} + (i₀ : ι) (L : ℕ) (hL : ∀ a, (encι (sel a)).length ≤ L) + (hsel : ∃ c, ComputableInTimeAndSpace sel encIn encι + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) : + ∃ c, ComputableInTimeAndSpace (fun a => decide (sel a = i₀)) encIn boolEnc + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + obtain ⟨c_sel, hsel'⟩ := hsel + obtain ⟨cψ, hψ⟩ := computableInTimeAndSpace_of_exists_finite_ne + (f := fun i => decide (i = i₀)) (encIn := encι) (encOut := boolEnc) + ⟨false, by + have hset : {i : ι | (fun i => decide (i = i₀)) i ≠ false} = {i₀} := by ext i; simp + rw [hset]; exact Set.finite_singleton i₀⟩ + obtain ⟨cC, hcomp⟩ := computableInTimeAndSpace_comp hsel' hψ + refine ⟨cC * (c_sel + cψ + L + 2), hcomp.mono (fun a => ?_) (fun a => ?_)⟩ + · rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left cC ?_ + have hL' := hL a + have hexp : (c_sel + cψ + L + 2) * (t a + s a + (encIn a).length + 1) = + c_sel * (t a + s a + (encIn a).length + 1) + cψ * (t a + s a + (encIn a).length + 1) + + L * (t a + s a + (encIn a).length + 1) + 2 * (t a + s a + (encIn a).length + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have h1 : cψ ≤ cψ * (t a + s a + (encIn a).length + 1) := Nat.le_mul_of_pos_right _ (by omega) + have h2 : L ≤ L * (t a + s a + (encIn a).length + 1) := Nat.le_mul_of_pos_right _ (by omega) + omega + · rw [Nat.mul_assoc] + refine Nat.mul_le_mul_left cC ?_ + have hL' := hL a + have hbl : (boolEnc (decide (sel a = i₀))).length = 1 := rfl + rw [hbl] + have hexp : (c_sel + cψ + L + 2) * (t a + s a + (encIn a).length + 1) = + c_sel * (t a + s a + (encIn a).length + 1) + cψ * (t a + s a + (encIn a).length + 1) + + L * (t a + s a + (encIn a).length + 1) + 2 * (t a + s a + (encIn a).length + 1) := by + rw [Nat.add_mul, Nat.add_mul, Nat.add_mul] + have h2 : L ≤ L * (t a + s a + (encIn a).length + 1) := Nat.le_mul_of_pos_right _ (by omega) + omega + +/-- The engine of `computableInTimeAndSpace_match`: induction on a finite set `R` covering the +scrutinee's values, everything carried in the normalised shape `c * (t a + s a + (encIn a).length + +1)`. At `insert i₀ R'` the scrutinee is split by the test `sel a = i₀`. -/ +private lemma match_aux {ι : Type} {br : ι → α → β} + {encι : ι ↪ List Bool} {encOut : β ↪ List Bool} (R : Finset ι) : + ∀ (sel : α → ι), (∀ a, sel a ∈ R) → + (∀ i ∈ R, ComputableInTimeAndSpace (br i) encIn encOut t s) → + (∃ c, ComputableInTimeAndSpace sel encIn encι + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1))) → + ∃ c, ComputableInTimeAndSpace (fun a => br (sel a) a) encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + classical + induction R using Finset.induction_on with + | empty => + intro sel hmem _ _ + have hemp : IsEmpty α := ⟨fun a => absurd (hmem a) (Finset.notMem_empty _)⟩ + let : Fintype α := Fintype.ofIsEmpty + obtain ⟨c, hc⟩ := + computableInTimeAndSpace_of_finite (encIn := encIn) (encOut := encOut) (fun a => br (sel a) a) + exact ⟨c, hc.mono (fun a => Nat.le_mul_of_pos_right c (by omega)) (fun a => Nat.zero_le _)⟩ + | @insert i₀ R' hi₀ IH => + intro sel hmem hbr hsel + by_cases hR'e : R' = ∅ + · subst hR'e + have hall : ∀ a, sel a = i₀ := by + intro a + have hm := hmem a + rw [Finset.mem_insert] at hm + rcases hm with h | h + · exact h + · exact absurd h (Finset.notMem_empty _) + have heq : (fun a => br (sel a) a) = br i₀ := funext fun a => by rw [hall a] + rw [heq] + exact ⟨1, (hbr i₀ (Finset.mem_insert_self i₀ ∅)).mono + (fun a => by omega) (fun a => by omega)⟩ + · obtain ⟨d, hd⟩ := Finset.nonempty_iff_ne_empty.mpr hR'e + have hL : ∀ a, (encι (sel a)).length ≤ (insert i₀ R').sup (fun i => (encι i).length) := + fun a => Finset.le_sup (f := fun i => (encι i).length) (hmem a) + obtain ⟨cc, hcc⟩ := cond_of_sel i₀ _ hL hsel + have hsel' : ∃ c, ComputableInTimeAndSpace + (fun a => bif decide (sel a = i₀) then d else sel a) encIn encι + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := + cond_norm ⟨cc, hcc⟩ (const_norm d) hsel + have hmem' : ∀ a, (fun a => bif decide (sel a = i₀) then d else sel a) a ∈ R' := by + intro a + by_cases h : sel a = i₀ + · simpa [h] using hd + · have hm := hmem a + simp only [Finset.mem_insert, h, false_or] at hm + simpa [h] using hm + obtain ⟨cRec, hRec⟩ := IH (fun a => bif decide (sel a = i₀) then d else sel a) + hmem' (fun i hi => hbr i (Finset.mem_insert_of_mem hi)) hsel' + have hGeq : (fun a => br (sel a) a) = + (fun a => bif decide (sel a = i₀) then br i₀ a + else br (bif decide (sel a = i₀) then d else sel a) a) := by + funext a + by_cases h : sel a = i₀ <;> simp [h] + rw [hGeq] + exact cond_norm ⟨cc, hcc⟩ + ⟨1, (hbr i₀ (Finset.mem_insert_self i₀ R')).mono (fun a => by omega) (fun a => by omega)⟩ + ⟨cRec, hRec⟩ + +/-- **Complexity of a case analysis on a finite type.** If the scrutinee and every branch are +computable, then so is the case analysis. The machine runs the machine for `sel`, redirecting its +output onto a work tape; since the scrutinee's range is finite there are only finitely many +possible contents, all of constant length, so the finite control can tell them apart in constant +time and continue with the machine for the branch that is taken, on the original input. + +What is asked of the scrutinee's type is not that it be finite but that only finitely many of its +values be reachable, which is what the machine needs: finitely many possible contents of the work +tape, of bounded length, for the control to tell apart. For a finite type that is `Set.toFinite _`. + +A single pair of bounds covers the scrutinee and every branch. The number of cases is a constant +of the covering set and is absorbed into the constant factor. What expresses that only the branch +taken is executed is that no time bound appears in the space bound: a machine computing every +branch would have to park their encoded outputs, whose length is bounded only by the time that +produced them, so its space would be `s a + t a`. + +A branch only has to *agree* with the function being computed where it is taken, which is what +`hagree` says; what it does elsewhere is irrelevant, since it is never run there. `f` carries no +information — it is `fun a => br (sel a) a` up to `funext` — but is kept because it is what a caller +has: their goal is a `match`, not an application of the branch family. It is inferred from the +goal, so apply this with `exact` or `refine` rather than `obtain`. -/ +public theorem computableInTimeAndSpace_match {ι : Type} + {sel : α → ι} {f : α → β} {br : ι → α → β} + {encι : ι ↪ List Bool} {encOut : β ↪ List Bool} + (hfin : (Set.range sel).Finite) + (hagree : ∀ a, br (sel a) a = f a) + (hsel : ComputableInTimeAndSpace sel encIn encι t s) + (hbr : ∀ i ∈ Set.range sel, ComputableInTimeAndSpace (br i) encIn encOut t s) : + ∃ c, ComputableInTimeAndSpace f encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + classical + obtain ⟨c, hc⟩ := match_aux hfin.toFinset sel + (fun a => hfin.mem_toFinset.mpr (Set.mem_range_self a)) + (fun i hi => hbr i (hfin.mem_toFinset.mp hi)) + ⟨1, hsel.mono (fun a => by omega) (fun a => by omega)⟩ + refine ⟨c, ?_⟩ + have hf : (fun a => br (sel a) a) = f := funext hagree + rwa [hf] at hc + +/-- **Complexity of Lean's `ite`.** A conditional on a decidable predicate, given a machine that +decides it. This is `computableInTimeAndSpace_cond` read through `decide`: the `Decidable` instance +of `ite` carries no computational content, so all that is needed of the predicate is that its +Boolean test is computable to `boolEnc`. -/ +public theorem computableInTimeAndSpace_ite {p : α → Prop} [DecidablePred p] {g h : α → β} + {encOut : β ↪ List Bool} {t s : α → ℕ} + (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc t s) + (hif : ComputableInTimeAndSpace g encIn encOut t s) + (helse : ComputableInTimeAndSpace h encIn encOut t s) : + ∃ c, ComputableInTimeAndSpace (fun a => if p a then g a else h a) encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + obtain ⟨c, hc⟩ := computableInTimeAndSpace_cond hp hif helse + refine ⟨c, ?_⟩ + have hfun : (fun a => bif decide (p a) then g a else h a) = + fun a => if p a then g a else h a := by + funext a; by_cases h : p a <;> simp [h] + rwa [hfun] at hc + +/-- **Complexity of Lean's `dite`.** The branches of a `dite` are not functions of the input alone: +each is defined only under the hypothesis that its case holds, so neither can be asked to be +computable as it stands. What is asked instead is a computable *total* function agreeing with the +branch where that branch is taken. -/ +public theorem computableInTimeAndSpace_dite {p : α → Prop} [DecidablePred p] + {_if : (a : α) → p a → β} {_else : (a : α) → ¬ p a → β} {If Else : α → β} + {encOut : β ↪ List Bool} {t s : α → ℕ} + (hIf : ∀ a (h : p a), If a = _if a h) + (hElse : ∀ a (h : ¬ p a), Else a = _else a h) + (hp : ComputableInTimeAndSpace (fun a => decide (p a)) encIn boolEnc t s) + (hif : ComputableInTimeAndSpace If encIn encOut t s) + (helse : ComputableInTimeAndSpace Else encIn encOut t s) : + ∃ c, ComputableInTimeAndSpace (fun a => dite (p a) (_if a) (_else a)) encIn encOut + (fun a => c * (t a + s a + (encIn a).length + 1)) + (fun a => c * (t a + s a + (encIn a).length + 1)) := by + obtain ⟨c, hc⟩ := computableInTimeAndSpace_ite (p := p) hp hif helse + refine ⟨c, ?_⟩ + have hfun : (fun a => if p a then If a else Else a) = + fun a => dite (p a) (_if a) (_else a) := by + funext a + by_cases h : p a + · simp [h, hIf a h] + · simp [h, hElse a h] + rwa [hfun] at hc + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean new file mode 100644 index 0000000000..8b1564993f --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Combinators/Loop.lean @@ -0,0 +1,788 @@ +/- +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 Mathlib.Basic.Finite.Sum +public import Mathlib.Data.PFun +public import Mathlib.Tactic.Ring +public import Mathlib.Computability.StateTransition +public import Cslib.Computability.Machines.Turing.MultiTape.Encodings.Option +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.Id +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Adapters +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Branch +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Repeat +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Clear +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Loop combinator + +This file is about the loop whose condition and body are fused into a single function +`body : α → Option α`, which returns `none` exactly when the loop is to stop: + +``` +loop + match body a with + | none => return a + | some a' => a := a' +``` + +This is the form in which the loop is implemented by a machine, since it needs only one machine for +the whole loop body. The usual `while` loop, with a separate condition and body, is the special case +obtained by fusing the condition into the body. + +## Main definitions + +* `Turing.MultiTapeTM.loopFunction`: the partial function computed by the loop, defined as + `StateTransition.eval` of the loop body. It is undefined on the inputs for which the loop + diverges. +* `Turing.MultiTapeTM.loopIterate`: the value after a given number of iterations, or `none` if the + loop has already stopped. + +## Main results + +* `Turing.MultiTapeTM.mem_loopFunction_iff`: the loop started at `a` terminates in `b` exactly if + `b` is an iterate of `a` at which the body stops. +* `Turing.MultiTapeTM.computableInTimeAndSpace_loopFunction`: the complexity of the loop. +-/ + +namespace Turing.MultiTapeTM + +variable {α : Type*} + +/-- The partial function computed by the loop with the fused body `body`, which returns `none` +exactly when the loop is to stop. It is defined exactly on the inputs for which the loop +terminates. -/ +@[expose] public def loopFunction (body : α → Option α) : α →. α := StateTransition.eval body + +/-- The value after `n` iterations of the fused loop body, or `none` if the loop has stopped +after at most `n` iterations. -/ +@[expose] public def loopIterate (body : α → Option α) : ℕ → α → Option α + | 0, a => some a + | n + 1, a => (body a).bind (loopIterate body n) + +section Iterate + +/-! ## The iterates of the loop body + +The loop is described by two views of its body: `loopIterate`, which is what the machine actually +runs through, and `loopFunction`, which is what it computes. This section relates them. +-/ + +variable {body : α → Option α} + +@[simp] +public lemma loopIterate_zero (a : α) : loopIterate body 0 a = some a := rfl + +public lemma loopIterate_succ (n : ℕ) (a : α) : + loopIterate body (n + 1) a = (body a).bind (loopIterate body n) := rfl + +@[simp] +public lemma loopIterate_one (a : α) : loopIterate body 1 a = body a := by + cases h : body a <;> simp [loopIterate_succ, h] + +/-- The iterates of the loop body compose. -/ +public lemma loopIterate_add (m n : ℕ) (a : α) : + loopIterate body (m + n) a = (loopIterate body m a).bind (loopIterate body n) := by + induction m generalizing a with + | zero => simp + | succ m ih => + cases h : body a with + | none => simp [show m + 1 + n = m + n + 1 by omega, loopIterate_succ, h] + | some b => simp [show m + 1 + n = m + n + 1 by omega, loopIterate_succ, h, ih] + +/-- One more iteration can also be performed at the end. -/ +public lemma loopIterate_succ' (n : ℕ) (a : α) : + loopIterate body (n + 1) a = (loopIterate body n a).bind body := by + rw [loopIterate_add] + simp + +/-- Once the loop has stopped it stays stopped. -/ +public lemma loopIterate_eq_none_of_le {m n : ℕ} {a : α} (h : m ≤ n) + (hm : loopIterate body m a = none) : loopIterate body n a = none := by + obtain ⟨d, rfl⟩ := Nat.exists_eq_add_of_le h + rw [loopIterate_add, hm] + rfl + +/-- Before the loop has stopped it has not stopped. -/ +public lemma loopIterate_ne_none_of_le {m n : ℕ} {a : α} (h : m ≤ n) + (hn : loopIterate body n a ≠ none) : loopIterate body m a ≠ none := + fun hm => hn (loopIterate_eq_none_of_le h hm) + +/-- As long as the loop has not stopped, each iterate is obtained from the previous one by a +successful call of the body. -/ +public lemma loopIterate_succ_of_lt {m n : ℕ} {a x : α} (hn : n < m) + (hm : loopIterate body m a ≠ none) (hx : loopIterate body n a = some x) : + ∃ x', body x = some x' ∧ loopIterate body (n + 1) a = some x' := by + have heq : loopIterate body (n + 1) a = body x := by rw [loopIterate_succ', hx]; simp + have hne : body x ≠ none := heq ▸ loopIterate_ne_none_of_le hn hm + obtain ⟨x', hx'⟩ := Option.ne_none_iff_exists'.mp hne + exact ⟨x', hx', by rw [heq, hx']⟩ + +/-- The values reachable by repeatedly applying the loop body are exactly its iterates. -/ +public lemma reaches_iff_loopIterate {a b : α} : + Relation.ReflTransGen (fun x y => y ∈ body x) a b ↔ ∃ n, loopIterate body n a = some b := by + constructor + · intro h + induction h using Relation.ReflTransGen.head_induction_on with + | refl => exact ⟨0, rfl⟩ + | head hstep _ ih => + obtain ⟨n, hn⟩ := ih + exact ⟨n + 1, by rw [loopIterate_succ, Option.mem_def.mp hstep]; exact hn⟩ + · rintro ⟨n, hn⟩ + induction n generalizing a with + | zero => + rw [loopIterate_zero, Option.some_inj] at hn + exact hn ▸ Relation.ReflTransGen.refl + | succ n ih => + rw [loopIterate_succ] at hn + cases hc : body a with + | none => rw [hc] at hn; simp at hn + | some c => + rw [hc] at hn + exact Relation.ReflTransGen.head (Option.mem_def.mpr hc) (ih hn) + +/-- **The graph of `loopFunction`.** The loop started at `a` terminates in `b` exactly if `b` is an +iterate of `a` at which the body stops. -/ +public theorem mem_loopFunction_iff {a b : α} : + b ∈ loopFunction body a ↔ ∃ n, loopIterate body n a = some b ∧ body b = none := by + rw [loopFunction, StateTransition.mem_eval, StateTransition.Reaches, reaches_iff_loopIterate] + exact ⟨fun ⟨⟨n, hn⟩, hb⟩ => ⟨n, hn, hb⟩, fun ⟨n, hn, hb⟩ => ⟨⟨n, hn⟩, hb⟩⟩ + +end Iterate + +section Bounds + +/-! ## Arithmetic helpers + +Every machine that the loop is assembled from costs a constant times the sum of a few lengths, and +every one of those lengths is bounded by a constant times `s a + 1` or `t a + s a + 1`. These +lemmas turn such a sum into a single constant times the bound. -/ + +private lemma nat_bound₀ {W u X : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) : X + 1 ≤ (W + 1) * u := by + calc X + 1 ≤ W * u + u := Nat.add_le_add hX hu + _ = (W + 1) * u := by ring + +private lemma nat_bound₁ {c W u X : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) : + c * (X + 1) ≤ c * (W + 1) * u := by + calc c * (X + 1) ≤ c * (W * u + u) := by gcongr + _ = c * (W + 1) * u := by ring + +private lemma nat_bound₂ {c W u X Y : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) (hY : Y ≤ W * u) : + c * (X + Y + 1) ≤ c * (2 * W + 1) * u := by + calc c * (X + Y + 1) ≤ c * (W * u + W * u + u) := by gcongr + _ = c * (2 * W + 1) * u := by ring + +private lemma nat_bound₃ {c W u X Y Z : ℕ} (hu : 1 ≤ u) (hX : X ≤ W * u) (hY : Y ≤ W * u) + (hZ : Z ≤ W * u) : c * (X + Y + Z + 1) ≤ c * (3 * W + 1) * u := by + calc c * (X + Y + Z + 1) ≤ c * (W * u + W * u + W * u + u) := by gcongr + _ = c * (3 * W + 1) * u := by ring + +/-- A constant summand is absorbed into the constant factor. -/ +private lemma nat_bound_add {c d u X : ℕ} (hu : 1 ≤ u) (hX : X ≤ c * u) : X + d ≤ (c + d) * u := by + calc X + d ≤ c * u + d * u := by gcongr; exact Nat.le_mul_of_pos_right d (by omega) + _ = (c + d) * u := by ring + +end Bounds + +section TapeWords + +/-! ## The vector of words on three named tapes + +Every configuration the loop machine passes through is blank outside of three named work tapes; +`tapeWords` is the vector of words of such a configuration. The tape-transformer machines return +whole vectors — their postconditions are equalities — so the projection, blankness and +`Function.update` equations here are all that is needed to glue the steps of the loop. -/ + +variable {K : ℕ} + +/-- The vector of words that holds `w₁`, `w₂` and `w₃` on the tapes `i₁`, `i₂` and `i₃` and is +blank everywhere else. -/ +private def tapeWords (i₁ i₂ i₃ : Fin K) (w₁ w₂ w₃ : List Bool) : Fin K → List Bool := + fun l => if l = i₁ then w₁ else if l = i₂ then w₂ else if l = i₃ then w₃ else [] + +variable {i₁ i₂ i₃ : Fin K} {w₁ w₂ w₃ w : List Bool} + +private lemma tapeWords_fst : tapeWords i₁ i₂ i₃ w₁ w₂ w₃ i₁ = w₁ := by + simp [tapeWords] + +private lemma tapeWords_snd (h₁₂ : i₁ ≠ i₂) : tapeWords i₁ i₂ i₃ w₁ w₂ w₃ i₂ = w₂ := by + simp [tapeWords, Ne.symm h₁₂] + +private lemma tapeWords_thd (h₁₃ : i₁ ≠ i₃) (h₂₃ : i₂ ≠ i₃) : + tapeWords i₁ i₂ i₃ w₁ w₂ w₃ i₃ = w₃ := by + simp [tapeWords, Ne.symm h₁₃, Ne.symm h₂₃] + +private lemma tapeWords_of_ne_fst {l : Fin K} (h₁ : l ≠ i₁) : + tapeWords i₁ i₂ i₃ w₁ [] [] l = [] := by + simp [tapeWords, h₁] + +private lemma tapeWords_of_ne_snd {l : Fin K} (h₂ : l ≠ i₂) : + tapeWords i₁ i₂ i₃ [] w₂ [] l = [] := by + simp [tapeWords, h₂] + +private lemma tapeWords_of_ne_fst_snd {l : Fin K} (h₁ : l ≠ i₁) (h₂ : l ≠ i₂) : + tapeWords i₁ i₂ i₃ w₁ w₂ [] l = [] := by + simp [tapeWords, h₁, h₂] + +private lemma update_tapeWords_fst : + Function.update (tapeWords i₁ i₂ i₃ w₁ w₂ w₃) i₁ w = tapeWords i₁ i₂ i₃ w w₂ w₃ := by + funext l + by_cases h : l = i₁ + · subst h; rw [Function.update_self, tapeWords_fst] + · rw [Function.update_of_ne h]; simp [tapeWords, h] + +private lemma update_tapeWords_snd (h₁₂ : i₁ ≠ i₂) : + Function.update (tapeWords i₁ i₂ i₃ w₁ w₂ w₃) i₂ w = tapeWords i₁ i₂ i₃ w₁ w w₃ := by + funext l + by_cases h : l = i₂ + · subst h; rw [Function.update_self, tapeWords_snd h₁₂] + · rw [Function.update_of_ne h]; simp [tapeWords, h] + +private lemma update_tapeWords_thd (h₁₃ : i₁ ≠ i₃) (h₂₃ : i₂ ≠ i₃) : + Function.update (tapeWords i₁ i₂ i₃ w₁ w₂ w₃) i₃ w = tapeWords i₁ i₂ i₃ w₁ w₂ w := by + funext l + by_cases h : l = i₃ + · subst h; rw [Function.update_self, tapeWords_thd h₁₃ h₂₃] + · rw [Function.update_of_ne h]; simp [tapeWords, h] + +end TapeWords + +-- The `Finite` instances of the machines that are combined are produced by `obtain`, so they have +-- to be registered as instances with `haveI` even though the goal is a proposition. +set_option linter.style.haveILetI false in +/-- **Complexity of a loop.** + +Assume that +* `f` picks, for every input, a value at which the loop terminates (`hf`), and the loop started at + `a` stops after at most `iterBound a` iterations (`hiter`); +* the loop body is computable in time `t` and space `s` (`hbody`), where `s` also bounds the + encoded length of all the values encountered while running the loop (`hsize`, which includes `a` + itself); +* these bounds do not increase along the iterations of the loop (`ht`, `hs`). + +Then `f` is computable in time proportional to the number of iterations times the cost of one +iteration, and in space proportional to the space of one iteration. + +The machine uses three named work tapes, `T1` holding the current value, `T3` holding the result of +the last call of the body and `T4` holding the flag that says whether the loop is over, plus the +scratch tapes of the machines it runs, which `exists_transformsTapes_ofComputable` hides. It first +copies its input onto `T1` and runs the machine for `body` with `T1` as its input tape and `T3` as +its output tape. Then it repeats: run the machine for `Option.isNone` on `T3`, writing the flag to +`T4`, and branch on the flag; if the loop is over, stop, so that the contents of `T1` can be +emitted; otherwise clear `T4`, clear `T1`, run the destructor of `some` with `T3` as its input and +`T1` as its output, clear `T3` and run the body again with `T1` as its input and `T3` as its +output. + +Note that `T1` has to be kept until the result of the body has been inspected, since on exit the +result of the loop is the value that was fed to the last call of the body. Copying the input onto +`T1` before the first call of the body costs only `O(s a)`, since `hsize` bounds the length of the +encoded input. + +The space bound of the body alone does not bound the encoded length of the intermediate values: the +input tape is read-only and the output tape is append-only, so neither counts towards the space +bound, and a machine can produce an output much longer than the space it uses. The intermediate +values, however, are stored on a work tape, and hence `hsize` is a genuine additional assumption on +`s`. Since the resulting bounds are stated up to a constant factor, using a single `s` for both +purposes is no weaker than using two separate bounds, whose maximum `s` can be taken to be. -/ +public theorem computableInTimeAndSpace_loopFunction + {α : Type*} {body : α → Option α} {f : α → α} + {enc : α ↪ List Bool} {encOpt : Option α ↪ List Bool} {t s iterBound : α → ℕ} + (henc : IsOptionEncoding enc encOpt) + (hf : ∀ a, f a ∈ loopFunction body a) + (hiter : ∀ a, ∃ m ≤ iterBound a, loopIterate body m a = none) + (hsize : ∀ a m x, loopIterate body m a = some x → (enc x).length ≤ s a) + (hbody : ComputableInTimeAndSpace body enc encOpt t s) + (ht : ∀ a m x, loopIterate body m a = some x → t x ≤ t a) + (hs : ∀ a m x, loopIterate body m a = some x → s x ≤ s a) : + ∃ c, ComputableInTimeAndSpace f enc enc + (fun a => c * (iterBound a + 1) * (t a + s a + 1)) + (fun a => c * (s a + 1)) := by + classical + -- ### The number of iterations + -- `N a` is the number of iterations after which the loop started at `a` stops, and `f a` is the + -- value it stops at. + have hkey : ∀ a, ∃ n, loopIterate body n a = some (f a) ∧ body (f a) = none := + fun a => mem_loopFunction_iff.mp (hf a) + choose N hN hNstop using hkey + have hNle : ∀ a, N a + 1 ≤ iterBound a := by + intro a + obtain ⟨m, hm, hmnone⟩ := hiter a + have hlt : N a < m := by + by_contra hcon + have hcontra := loopIterate_eq_none_of_le (Nat.le_of_not_lt hcon) hmnone + rw [hN a] at hcontra + simp at hcontra + omega + -- every round before `N a` produces the value the next one starts at + have hnext : ∀ a n, n < N a → ∀ x, loopIterate body n a = some x → + ∃ x', body x = some x' ∧ loopIterate body (n + 1) a = some x' := + fun a n hn x hx => loopIterate_succ_of_lt hn + (by rw [hN a]; exact Option.some_ne_none _) hx + -- ### The encoding of the loop flag + obtain ⟨encBool, hencBoolHead, hencBoolLen⟩ : + ∃ e : Bool ↪ List Bool, (∀ b, (e b).head? = some b) ∧ ∀ b, (e b).length = 1 := + ⟨⟨fun b => [b], fun b₁ b₂ h => by simpa using h⟩, fun _ => rfl, fun _ => rfl⟩ + -- ### Lengths of the encodings encountered along the loop + obtain ⟨cc, hcc⟩ := henc.constructor_computable + have hccLen : ∀ x : α, (encOpt (some x)).length ≤ cc * ((enc x).length + 1) := + hcc.length_encOut_le + obtain ⟨E, hE⟩ : ∃ E, ∀ a n x, loopIterate body n a = some x → + (encOpt (body x)).length ≤ E * (s a + 1) := by + refine ⟨cc + (encOpt none).length, fun a n x hx => ?_⟩ + rcases hb : body x with _ | x' + · calc (encOpt none).length ≤ cc + (encOpt none).length := Nat.le_add_left _ _ + _ ≤ (cc + (encOpt none).length) * (s a + 1) := + Nat.le_mul_of_pos_right _ (Nat.succ_pos _) + · have hx' : loopIterate body (n + 1) a = some x' := by + rw [loopIterate_succ', hx]; simpa using hb + calc (encOpt (some x')).length ≤ cc * ((enc x').length + 1) := hccLen x' + _ ≤ cc * (s a + 1) := Nat.mul_le_mul_left _ (by have := hsize a (n + 1) x' hx'; omega) + _ ≤ (cc + (encOpt none).length) * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The machines the loop is assembled from + obtain ⟨cd, hd⟩ := henc.destructor_computable + obtain ⟨cn, hisNone⟩ := + computableInTimeAndSpace_isNone (α := α) (encOpt := encOpt) (encBool := encBool) + obtain ⟨ci, hid⟩ : ∃ c, ComputableInTimeAndSpace (id : α → α) enc enc + (fun a => c * ((enc a).length + 1)) (fun _ => 0) := + ⟨1, computableInTimeAndSpace_id.mono (fun a => (one_mul _).symm.le) (fun _ => le_rfl)⟩ + obtain ⟨mB, cB, hB⟩ := exists_transformsTapes_ofComputable hbody + obtain ⟨mD, cD, hD⟩ := exists_transformsTapes_ofComputable hd + obtain ⟨mN, cN, hNm⟩ := exists_transformsTapes_ofComputable hisNone + obtain ⟨mI, cI, hI⟩ := exists_transformsTapes_ofComputableInput hid + -- the tape layout: `T1` the current value, `T3` the result of the body, `T4` the flag + obtain ⟨K, T1, T3, T4, hT13, hT14, hT34, hKB, hKD, hKN, hKI⟩ : + ∃ (K : ℕ) (T1 T3 T4 : Fin K), T1 ≠ T3 ∧ T1 ≠ T4 ∧ T3 ≠ T4 ∧ + mB + 2 ≤ K ∧ mD + 2 ≤ K ∧ mN + 3 ≤ K ∧ mI + 1 ≤ K := + ⟨mB + mD + mN + mI + 5, ⟨0, by omega⟩, ⟨1, by omega⟩, ⟨2, by omega⟩, + Fin.ne_of_val_ne (by simp), Fin.ne_of_val_ne (by simp), Fin.ne_of_val_ne (by simp), + by omega, by omega, by omega, by omega⟩ + obtain ⟨SB, hSB, MBody, hMBody⟩ := + hB K T1 T3 ∅ hT13 (by simp) (by simp) (by simpa using hKB) + obtain ⟨SD, hSD, MDestr, hMDestr⟩ := + hD K T3 T1 ∅ (Ne.symm hT13) (by simp) (by simp) (by simpa using hKD) + obtain ⟨SN, hSN, MIsNone, hMIsNone⟩ := + hNm K T3 T4 {T1} hT34 (by simpa using Ne.symm hT13) (by simpa using Ne.symm hT14) + (by simp only [Finset.card_singleton]; omega) + obtain ⟨SI, hSI, MCopy, hMCopy⟩ := hI K T1 ∅ (by simp) (by simpa using hKI) + obtain ⟨cC1, SC1, hSC1, MClear1, hMClear1⟩ := exists_transformsTapes_clear (Symbol := Bool) T1 + obtain ⟨cC3, SC3, hSC3, MClear3, hMClear3⟩ := exists_transformsTapes_clear (Symbol := Bool) T3 + obtain ⟨cC4, SC4, hSC4, MClear4, hMClear4⟩ := exists_transformsTapes_clear (Symbol := Bool) T4 + obtain ⟨SNop, hSNop, MNop, hMNop⟩ := exists_transformsTapes_nop K Bool + haveI := hSB; haveI := hSD; haveI := hSN; haveI := hSI + haveI := hSC1; haveI := hSC3; haveI := hSC4; haveI := hSNop + -- ### One constant bounding every length that occurs + obtain ⟨W, hW1, hWci, hWlen⟩ : ∃ W : ℕ, 1 ≤ W ∧ ci ≤ W ∧ + ∀ a n x, loopIterate body n a = some x → + (enc x).length ≤ W * (s a + 1) ∧ + (encOpt (body x)).length ≤ W * (s a + 1) ∧ + (encOpt (some x)).length ≤ W * (s a + 1) ∧ + cd * ((encOpt (some x)).length + 1) ≤ W * (s a + 1) ∧ + s x ≤ W * (s a + 1) ∧ t x ≤ W * (t a + s a + 1) := by + refine ⟨ci + cc + E + cd * (cc + 1) + 1, by omega, by omega, + fun a n x hx => ⟨?_, ?_, ?_, ?_, ?_, ?_⟩⟩ + · exact le_trans (by have := hsize a n x hx; omega) + (Nat.le_mul_of_pos_left _ (by omega)) + · exact (hE a n x hx).trans (Nat.mul_le_mul_right _ (by omega)) + · exact (hccLen x).trans ((Nat.mul_le_mul_left _ (by have := hsize a n x hx; omega)).trans + (Nat.mul_le_mul_right _ (by omega))) + · have h1 : (encOpt (some x)).length ≤ cc * (s a + 1) := + (hccLen x).trans (Nat.mul_le_mul_left _ (by have := hsize a n x hx; omega)) + calc cd * ((encOpt (some x)).length + 1) + ≤ cd * (cc * (s a + 1) + (s a + 1)) := + Nat.mul_le_mul_left _ (Nat.add_le_add h1 (by omega)) + _ = cd * (cc + 1) * (s a + 1) := by ring + _ ≤ _ := Nat.mul_le_mul_right _ (by omega) + · exact le_trans (by have := hs a n x hx; omega) (Nat.le_mul_of_pos_left _ (by omega)) + · exact le_trans (by have := ht a n x hx; omega) (Nat.le_mul_of_pos_left _ (by omega)) + -- the two units in which the bounds are measured + have hu1 : ∀ a, 1 ≤ t a + s a + 1 := fun a => by omega + have hv1 : ∀ a, 1 ≤ s a + 1 := fun a => by omega + have hvu : ∀ (a : α) (c : ℕ), c * (s a + 1) ≤ c * (t a + s a + 1) := + fun a c => Nat.mul_le_mul_left _ (by omega) + -- ### Descriptions of the tape contents at the various points of a round + -- Every configuration of the loop is a `tapeWords T1 T3 T4` vector, and the machines return + -- whole vectors, so the steps below are glued by rewriting with the equations of `tapeWords`. + -- The predicates are obtained from existentials so that they are unfolded only where intended. + obtain ⟨Pround, hPround⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y, loopIterate body n a = some y ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) []) := ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨PMid, hPMid⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y, loopIterate body n a = some y ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) (encBool (body y).isNone)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨PExit, hPExit⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y, loopIterate body n a = some y ∧ body y = none ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) (encBool (body y).isNone)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨PCont, hPCont⟩ : ∃ P : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws, P a n ws ↔ + (∃ y y', loopIterate body n a = some y ∧ body y = some y' ∧ + ws = tapeWords T1 T3 T4 (enc y) (encOpt (body y)) (encBool (body y).isNone)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + obtain ⟨QR, hQR⟩ : ∃ Q : α → ℕ → (Fin K → List Bool) → Prop, ∀ a n ws', Q a n ws' ↔ + ((∀ y, loopIterate body n a = some y → body y = none → + ws' T1 = enc y ∧ (ws' T4).head? = some true) ∧ + (∀ y y', loopIterate body n a = some y → body y = some y' → + ws' = tapeWords T1 T3 T4 (enc y') (encOpt (body y')) [] ∧ + (ws' T4).head? ≠ some true)) := + ⟨_, fun _ _ _ => Iff.rfl⟩ + -- ### Bounds for the individual machines + -- Every length occurring in the bound of a machine of a round is bounded by `W * (s a + 1)`, + -- hence its time by a constant times `t a + s a + 1` and its space by a constant times `s a + 1`. + have hcW : ∀ (c : ℕ) (a : α), c ≤ W → c ≤ W * (t a + s a + 1) := fun c a hc => + hc.trans (Nat.le_mul_of_pos_right _ (by omega)) + have hcWv : ∀ (c : ℕ) (a : α), c ≤ W → c ≤ W * (s a + 1) := fun c a hc => + hc.trans (Nat.le_mul_of_pos_right _ (by omega)) + obtain ⟨A1, hA1⟩ : ∃ c, ∀ a : α, cN * (cn + 1) ≤ c * (t a + s a + 1) := + ⟨cN * (cn + 1), fun a => Nat.le_mul_of_pos_right _ (by omega)⟩ + obtain ⟨A2, hA2⟩ : ∃ c, ∀ (a : α) (b : Bool), + cC4 * ((encBool b).length + 1) ≤ c * (t a + s a + 1) := by + refine ⟨cC4 * (W + 1), fun a b => ?_⟩ + rw [hencBoolLen] + exact nat_bound₁ (hu1 a) (hcW 1 a hW1) + obtain ⟨A3, hA3⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cC1 * ((enc x).length + 1) ≤ c * (t a + s a + 1) := + ⟨cC1 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ((hWlen a n x hx).1.trans (hvu a W))⟩ + obtain ⟨A4, hA4⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cD * (cd * ((encOpt (some x)).length + 1) + 1) ≤ c * (t a + s a + 1) := + ⟨cD * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ((hWlen a n x hx).2.2.2.1.trans (hvu a W))⟩ + obtain ⟨A5, hA5⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cC3 * ((encOpt (some x)).length + 1) ≤ c * (t a + s a + 1) := + ⟨cC3 * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ((hWlen a n x hx).2.2.1.trans (hvu a W))⟩ + obtain ⟨A6, hA6⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cB * (t x + 1) ≤ c * (t a + s a + 1) := + ⟨cB * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) (hWlen a n x hx).2.2.2.2.2⟩ + obtain ⟨A7, hA7⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cI * (ci * ((enc x).length + 1) + 1) ≤ c * (t a + s a + 1) := by + refine ⟨cI * (W + 1), fun a n x hx => nat_bound₁ (hu1 a) ?_⟩ + calc ci * ((enc x).length + 1) ≤ ci * (s a + 1) := + Nat.mul_le_mul_left _ (by have := hsize a n x hx; omega) + _ ≤ W * (s a + 1) := Nat.mul_le_mul_right _ hWci + _ ≤ W * (t a + s a + 1) := hvu a W + obtain ⟨B1, hB1⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cN * (0 + (encOpt (body x)).length + (encBool (body x).isNone).length + 1) + K + ≤ c * (s a + 1) := by + refine ⟨cN * (3 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) ?_⟩ + rw [hencBoolLen] + exact nat_bound₃ (hv1 a) (hcWv 0 a (by omega)) (hWlen a n x hx).2.1 (hcWv 1 a hW1) + obtain ⟨B2, hB2⟩ : ∃ c, ∀ (a : α) (w : List Bool), w.length ≤ W * (s a + 1) → + w.length + 1 + K ≤ c * (s a + 1) := + ⟨W + 1 + K, fun a w hw => nat_bound_add (hv1 a) (nat_bound₀ (hv1 a) hw)⟩ + obtain ⟨B3, hB3⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cD * (0 + (encOpt (some x)).length + (enc x).length + 1) + K ≤ c * (s a + 1) := + ⟨cD * (3 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) + (nat_bound₃ (hv1 a) (hcWv 0 a (by omega)) (hWlen a n x hx).2.2.1 (hWlen a n x hx).1)⟩ + obtain ⟨B4, hB4⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cB * (s x + (enc x).length + (encOpt (body x)).length + 1) + K ≤ c * (s a + 1) := + ⟨cB * (3 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) + (nat_bound₃ (hv1 a) (hWlen a n x hx).2.2.2.2.1 (hWlen a n x hx).1 + (hWlen a n x hx).2.1)⟩ + obtain ⟨B5, hB5⟩ : ∃ c, ∀ a n x, loopIterate body n a = some x → + cI * (0 + (enc x).length + 1) + K ≤ c * (s a + 1) := + ⟨cI * (2 * W + 1) + K, fun a n x hx => nat_bound_add (hv1 a) + (nat_bound₂ (hv1 a) (hcWv 0 a (by omega)) (hWlen a n x hx).1)⟩ + -- the cost of one round, and of the whole loop + set A : ℕ := A1 + A2 + A3 + A4 + A5 + A6 + A7 + 1 with hAdef + set B : ℕ := B1 + 3 * B2 + B3 + B4 + B5 + K + 1 with hBdef + -- ### The exit branch: the loop is over, so nothing is left to do + have hExit : ∀ p : α × ℕ, TransformsTapes MNop (fun _ ws => PExit p.1 p.2 ws) + (fun _ _ ws' => QR p.1 p.2 ws') (A * (t p.1 + s p.1 + 1)) (B * (s p.1 + 1)) := by + rintro ⟨a, n⟩ + refine hMNop.imp (fun _ _ _ => trivial) (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · rw [hQ] + obtain ⟨y, hy, hby, hws⟩ := (hPExit a n ws).mp hP + refine (hQR a n ws).mpr ⟨fun z hz _ => ?_, fun z z' hz hbz => ?_⟩ + · rw [hy] at hz + obtain rfl : z = y := (Option.some.inj hz).symm + refine ⟨by rw [hws, tapeWords_fst], ?_⟩ + simp [hws, tapeWords_thd hT14 hT34, hby, hencBoolHead] + · rw [hy] at hz + obtain rfl : z = y := (Option.some.inj hz).symm + rw [hby] at hbz + exact absurd hbz (by simp) + · calc (1 : ℕ) ≤ 1 * (t a + s a + 1) := by omega + _ ≤ A * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · calc K ≤ K * (s a + 1) := Nat.le_mul_of_pos_right _ (by omega) + _ ≤ B * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The continuation branch: one more iteration of the loop body + have hCont : ∀ p : α × ℕ, TransformsTapes + (MClear4.seq (MClear1.seq (MDestr.seq (MClear3.seq MBody)))) + (fun _ ws => PCont p.1 p.2 ws) (fun _ _ ws' => QR p.1 p.2 ws') + (A * (t p.1 + s p.1 + 1)) (B * (s p.1 + 1)) := by + rintro ⟨a, n⟩ + rcases hit : loopIterate body n a with _ | x + · intro input ws out hP + obtain ⟨y, y', hy, _, _⟩ := (hPCont a n ws).mp hP + rw [hit] at hy + exact absurd hy (by simp) + rcases hb : body x with _ | x' + · intro input ws out hP + obtain ⟨y, y', hy, hby, _⟩ := (hPCont a n ws).mp hP + rw [hit] at hy + obtain rfl : y = x := (Option.some.inj hy).symm + rw [hb] at hby + exact absurd hby (by simp) + have hx' : loopIterate body (n + 1) a = some x' := by + rw [loopIterate_succ', hit]; simpa using hb + have hPC : ∀ ws, PCont a n ws → + ws = tapeWords T1 T3 T4 (enc x) (encOpt (body x)) (encBool (body x).isNone) := by + intro ws hP + obtain ⟨y, y', hy, _, hws⟩ := (hPCont a n ws).mp hP + rw [hit] at hy + obtain rfl : y = x := (Option.some.inj hy).symm + exact hws + -- clear the flag tape + have step4 : TransformsTapes MClear4 (fun _ ws => PCont a n ws) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x) (encOpt (some x')) []) + (cC4 * ((encBool (body x).isNone).length + 1)) + ((encBool (body x).isNone).length + 1 + K) := + (hMClear4 (encBool (body x).isNone)).imp + (fun _ ws hP => by rw [hPC ws hP, tapeWords_thd hT14 hT34]) + (fun _ ws ws' hP hQ => by + rw [hQ, hPC ws hP, update_tapeWords_thd hT14 hT34, hb]) le_rfl le_rfl + -- clear the tape holding the current value + have step1 : TransformsTapes MClear1 + (fun _ ws => ws = tapeWords T1 T3 T4 (enc x) (encOpt (some x')) []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 [] (encOpt (some x')) []) + (cC1 * ((enc x).length + 1)) ((enc x).length + 1 + K) := + (hMClear1 (enc x)).imp (fun _ ws hP => by rw [hP, tapeWords_fst]) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_fst]) le_rfl le_rfl + -- extract the new value from the result of the body + have stepD : TransformsTapes MDestr + (fun _ ws => ws = tapeWords T1 T3 T4 [] (encOpt (some x')) []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x') (encOpt (some x')) []) + (cD * (cd * ((encOpt (some x')).length + 1) + 1)) + (cD * (0 + (encOpt (some x')).length + (enc x').length + 1) + K) := + (hMDestr x').imp + (fun _ ws hP => ⟨by rw [hP, tapeWords_snd hT13]; simp, + fun l hl3 _ => by rw [hP]; exact tapeWords_of_ne_snd hl3⟩) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_fst]; simp) le_rfl le_rfl + -- clear the tape holding the result of the body + have step3 : TransformsTapes MClear3 + (fun _ ws => ws = tapeWords T1 T3 T4 (enc x') (encOpt (some x')) []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x') [] []) + (cC3 * ((encOpt (some x')).length + 1)) ((encOpt (some x')).length + 1 + K) := + (hMClear3 (encOpt (some x'))).imp (fun _ ws hP => by rw [hP, tapeWords_snd hT13]) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_snd hT13]) le_rfl le_rfl + -- run the body on the new value + have stepB : TransformsTapes MBody (fun _ ws => ws = tapeWords T1 T3 T4 (enc x') [] []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc x') (encOpt (body x')) []) + (cB * (t x' + 1)) + (cB * (s x' + (enc x').length + (encOpt (body x')).length + 1) + K) := + (hMBody x').imp + (fun _ ws hP => ⟨by rw [hP, tapeWords_fst], + fun l hl1 _ => by rw [hP]; exact tapeWords_of_ne_fst hl1⟩) + (fun _ ws ws' hP hQ => by rw [hQ, hP, update_tapeWords_snd hT13]) le_rfl le_rfl + refine (transformsTapes_seq step4 (transformsTapes_seq step1 (transformsTapes_seq stepD + (transformsTapes_seq step3 stepB (fun _ _ _ _ h => h)) (fun _ _ _ _ h => h)) + (fun _ _ _ _ h => h)) (fun _ _ _ _ h => h)).imp (fun _ _ h => h) + (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · obtain ⟨_, rfl, _, rfl, _, rfl, _, rfl, hfin⟩ := hQ + refine (hQR a n ws').mpr ⟨fun z hz hbz => ?_, fun z z' hz hbz => ?_⟩ + · rw [hit] at hz + obtain rfl : z = x := (Option.some.inj hz).symm + rw [hb] at hbz + exact absurd hbz (by simp) + · rw [hit] at hz + obtain rfl : z = x := (Option.some.inj hz).symm + rw [hb] at hbz + obtain rfl : z' = x' := (Option.some.inj hbz).symm + exact ⟨hfin, by rw [hfin, tapeWords_thd hT14 hT34]; simp⟩ + · have e2 := hA2 a (body x).isNone + have e3 := hA3 a n x hit + have e4 := hA4 a (n + 1) x' hx' + have e5 := hA5 a (n + 1) x' hx' + have e6 := hA6 a (n + 1) x' hx' + calc _ ≤ A2 * (t a + s a + 1) + (A3 * (t a + s a + 1) + (A4 * (t a + s a + 1) + + (A5 * (t a + s a + 1) + A6 * (t a + s a + 1)))) := + Nat.add_le_add e2 (Nat.add_le_add e3 (Nat.add_le_add e4 (Nat.add_le_add e5 e6))) + _ = (A2 + A3 + A4 + A5 + A6) * (t a + s a + 1) := by ring + _ ≤ A * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · have g2 := hB2 a (encBool (body x).isNone) (by rw [hencBoolLen]; exact hcWv 1 a hW1) + have g3 := hB2 a (enc x) (hWlen a n x hit).1 + have g4 := hB3 a (n + 1) x' hx' + have g5 := hB2 a (encOpt (some x')) (hWlen a (n + 1) x' hx').2.2.1 + have g6 := hB4 a (n + 1) x' hx' + calc _ ≤ B2 * (s a + 1) + (B2 * (s a + 1) + (B3 * (s a + 1) + + (B2 * (s a + 1) + B4 * (s a + 1)))) := + Nat.add_le_add g2 (Nat.add_le_add g3 (Nat.add_le_add g4 (Nat.add_le_add g5 g6))) + _ = (B2 + B2 + B3 + B2 + B4) * (s a + 1) := by ring + _ ≤ B * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### One round: compute the flag on `T4` and branch on it + obtain ⟨SBr, hSBr, MBranch, hMBranch⟩ := + exists_transformsTapes_branch (J := α × ℕ) T4 true + (P₁ := fun p _ ws => PExit p.1 p.2 ws) (P₂ := fun p _ ws => PCont p.1 p.2 ws) + (Q := fun p _ _ ws' => QR p.1 p.2 ws') + (t₁ := fun p => A * (t p.1 + s p.1 + 1)) (s₁ := fun p => B * (s p.1 + 1)) + (t₂ := fun p => A * (t p.1 + s p.1 + 1)) (s₂ := fun p => B * (s p.1 + 1)) hExit hCont + haveI := hSBr + set A' : ℕ := A1 + A + 1 with hA'def + set B' : ℕ := B1 + B + K + 1 with hB'def + have hRound : ∀ (a : α) (n : ℕ), TransformsTapes (MIsNone.seq MBranch) + (fun _ ws => Pround a n ws) (fun _ _ ws' => QR a n ws') + (A' * (t a + s a + 1)) (B' * (s a + 1)) := by + intro a n + rcases hit : loopIterate body n a with _ | x + · intro input ws out hP + obtain ⟨y, hy, _⟩ := (hPround a n ws).mp hP + rw [hit] at hy + exact absurd hy (by simp) + have hPr : ∀ ws, Pround a n ws → ws = tapeWords T1 T3 T4 (enc x) (encOpt (body x)) [] := by + intro ws hP + obtain ⟨y, hy, hws⟩ := (hPround a n ws).mp hP + rw [hit] at hy + obtain rfl : y = x := (Option.some.inj hy).symm + exact hws + have stepN : TransformsTapes MIsNone (fun _ ws => Pround a n ws) + (fun _ _ ws' => PMid a n ws') + (cN * (cn + 1)) + (cN * (0 + (encOpt (body x)).length + (encBool (body x).isNone).length + 1) + K) := + (hMIsNone (body x)).imp + (fun _ ws hP => ⟨by rw [hPr ws hP, tapeWords_snd hT13], + fun l hl3 hl1 => by + rw [hPr ws hP]; exact tapeWords_of_ne_fst_snd (by simpa using hl1) hl3⟩) + (fun _ ws ws' hP hQ => + (hPMid a n ws').mpr ⟨x, hit, by + rw [hQ, hPr ws hP, update_tapeWords_thd hT14 hT34]⟩) le_rfl le_rfl + refine (transformsTapes_seq stepN (hMBranch (a, n)) (fun _ ws ws' hP hQ => ?_)).imp + (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · -- the flag decides which branch is taken + obtain ⟨y, hy, hws⟩ := (hPMid a n ws').mp hQ + by_cases hflag : (ws' T4).head? = some true + · rw [ite_eq_left hflag] + rw [hws, tapeWords_thd hT14 hT34, hencBoolHead] at hflag + exact (hPExit a n ws').mpr ⟨y, hy, by simpa using hflag, hws⟩ + · rw [ite_eq_right hflag] + rcases hby : body y with _ | y' + · exact absurd (by simp [hws, tapeWords_thd hT14 hT34, hby, hencBoolHead]) hflag + · exact (hPCont a n ws').mpr ⟨y, y', hy, hby, hws⟩ + · obtain ⟨_, -, h2⟩ := hQ + exact h2 + · simp only [max_self] + have e1 := hA1 a + calc _ ≤ A1 * (t a + s a + 1) + (A * (t a + s a + 1) + 1 * (t a + s a + 1)) := + Nat.add_le_add e1 (Nat.add_le_add le_rfl (by omega)) + _ = (A1 + A + 1) * (t a + s a + 1) := by ring + _ ≤ A' * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · simp only [max_self] + have g1 := hB1 a n x hit + calc _ ≤ B1 * (s a + 1) + (B * (s a + 1) + K * (s a + 1)) := + Nat.add_le_add g1 (Nat.add_le_add le_rfl (Nat.le_mul_of_pos_right _ (by omega))) + _ = (B1 + B + K) * (s a + 1) := by ring + _ ≤ B' * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The loop: repeat the round until the flag says that the loop is over + have hroundOK : ∀ (a : α) (n : ℕ), n < N a → TransformsTapes (MIsNone.seq MBranch) + (fun _ ws => Pround a n ws) + (fun _ _ ws' => Pround a (n + 1) ws' ∧ (ws' T4).head? ≠ some true) + (A' * (t a + s a + 1)) (B' * (s a + 1)) := by + intro a n hn + refine (hRound a n).imp (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + obtain ⟨y, hy, -⟩ := (hPround a n ws).mp hP + obtain ⟨y', hby, hy'⟩ := hnext a n hn y hy + obtain ⟨-, q2⟩ := (hQR a n ws').mp hQ + obtain ⟨hb', hflag⟩ := q2 y y' hy hby + exact ⟨(hPround a (n + 1) ws').mpr ⟨y', hy', hb'⟩, hflag⟩ + have hstopOK : ∀ a : α, TransformsTapes (MIsNone.seq MBranch) + (fun _ ws => Pround a (N a) ws) + (fun _ _ ws' => ws' T1 = enc (f a) ∧ (ws' T4).head? = some true) + (A' * (t a + s a + 1)) (B' * (s a + 1)) := by + intro a + refine (hRound a (N a)).imp (fun _ _ h => h) (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + exact ((hQR a (N a) ws').mp hQ).1 (f a) (hN a) (hNstop a) + obtain ⟨SL, hSL, MLoop, hMLoop⟩ := + exists_transformsTapes_repeat (J := α) T4 true + (P := fun a n _ ws => Pround a n ws) (R := fun a _ ws' => ws' T1 = enc (f a)) + (N := N) (t := fun a => A' * (t a + s a + 1)) (s := fun a => B' * (s a + 1)) + hroundOK hstopOK + haveI := hSL + -- ### The prologue: copy the input onto `T1` and run the body once + have hPro : ∀ a : α, TransformsTapes (MCopy.seq MBody) + (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ _ ws' => Pround a 0 ws') (A * (t a + s a + 1)) (B * (s a + 1)) := by + intro a + have s1 : TransformsTapes MCopy (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' = tapeWords T1 T3 T4 (enc a) [] []) + (cI * (ci * ((enc a).length + 1) + 1)) + (cI * (0 + (enc a).length + 1) + K) := by + refine (hMCopy a).imp (fun _ ws hP => ⟨hP.1, fun l _ => hP.2 l⟩) + (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + have hws : ws = tapeWords T1 T3 T4 [] [] [] := by + funext l + rw [hP.2 l] + by_cases h1 : l = T1 + · subst h1; rw [tapeWords_fst] + · rw [tapeWords_of_ne_fst h1] + rw [hQ, hws, update_tapeWords_fst] + simp + have s2 : TransformsTapes MBody (fun _ ws => ws = tapeWords T1 T3 T4 (enc a) [] []) + (fun _ _ ws' => Pround a 0 ws') + (cB * (t a + 1)) + (cB * (s a + (enc a).length + (encOpt (body a)).length + 1) + K) := + (hMBody a).imp + (fun _ ws hP => ⟨by rw [hP, tapeWords_fst], + fun l hl1 _ => by rw [hP]; exact tapeWords_of_ne_fst hl1⟩) + (fun _ ws ws' hP hQ => (hPround a 0 ws').mpr + ⟨a, rfl, by rw [hQ, hP, update_tapeWords_snd hT13]⟩) + le_rfl le_rfl + refine (transformsTapes_seq s1 s2 (fun _ _ _ _ h => h)).imp (fun _ _ h => h) + (fun _ ws ws' hP hQ => ?_) ?_ ?_ + · obtain ⟨_, -, h2⟩ := hQ + exact h2 + · calc _ ≤ A7 * (t a + s a + 1) + A6 * (t a + s a + 1) := + Nat.add_le_add (hA7 a 0 a rfl) (hA6 a 0 a rfl) + _ = (A7 + A6) * (t a + s a + 1) := by ring + _ ≤ A * (t a + s a + 1) := Nat.mul_le_mul_right _ (by omega) + · calc _ ≤ B5 * (s a + 1) + B4 * (s a + 1) := + Nat.add_le_add (hB5 a 0 a rfl) (hB4 a 0 a rfl) + _ = (B5 + B4) * (s a + 1) := by ring + _ ≤ B * (s a + 1) := Nat.mul_le_mul_right _ (by omega) + -- ### The whole machine + have hMain : ∀ a : α, TransformsTapes ((MCopy.seq MBody).seq MLoop) + (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' T1 = enc (f a)) + (A * (t a + s a + 1) + (N a + 1) * (A' * (t a + s a + 1) + 1)) + (B * (s a + 1) + (2 * K * (B' * (s a + 1)) + K)) := by + intro a + refine (transformsTapes_seq (hPro a) (hMLoop a) (fun _ _ _ _ h => h)).imp (fun _ _ h => h) + (fun _ ws ws' hP hQ => ?_) le_rfl le_rfl + obtain ⟨_, -, h2⟩ := hQ + exact h2 + obtain ⟨c₀, hc₀⟩ := computableInTimeAndSpace_of_transformsTapes T1 hMain + -- ### The final bounds + refine ⟨c₀ * (A + A' + 2) + c₀ * (B + 2 * K * B' + K + 2), hc₀.mono (fun a => ?_) (fun a => ?_)⟩ + · have hl : (enc (f a)).length ≤ s a := hsize a (N a) (f a) (hN a) + have h1 : (N a + 1) * (A' * (t a + s a + 1) + 1) + ≤ iterBound a * ((A' + 1) * (t a + s a + 1)) := by + refine Nat.mul_le_mul (hNle a) ?_ + calc A' * (t a + s a + 1) + 1 ≤ A' * (t a + s a + 1) + (t a + s a + 1) := by omega + _ = (A' + 1) * (t a + s a + 1) := by ring + have hkey : A + iterBound a * (A' + 1) + 2 ≤ (A + A' + 2) * (iterBound a + 1) := by + have hm1 : iterBound a * (A' + 1) ≤ (A + A' + 2) * iterBound a := by + rw [Nat.mul_comm] + exact Nat.mul_le_mul_right _ (by omega) + have hm2 : (A + A' + 2) * (iterBound a + 1) + = (A + A' + 2) * iterBound a + (A + A' + 2) := by ring + omega + calc c₀ * (A * (t a + s a + 1) + (N a + 1) * (A' * (t a + s a + 1) + 1) + + (enc (f a)).length + 1) + ≤ c₀ * (A * (t a + s a + 1) + iterBound a * ((A' + 1) * (t a + s a + 1)) + + (t a + s a + 1) + (t a + s a + 1)) := Nat.mul_le_mul_left _ (by omega) + _ = c₀ * ((A + iterBound a * (A' + 1) + 2) * (t a + s a + 1)) := by ring + _ ≤ c₀ * (((A + A' + 2) * (iterBound a + 1)) * (t a + s a + 1)) := + Nat.mul_le_mul_left _ (Nat.mul_le_mul_right _ hkey) + _ = c₀ * (A + A' + 2) * (iterBound a + 1) * (t a + s a + 1) := by ring + _ ≤ _ := Nat.mul_le_mul_right _ (Nat.mul_le_mul_right _ (by omega)) + · have hl : (enc (f a)).length ≤ s a := hsize a (N a) (f a) (hN a) + have hK1 : K ≤ K * (s a + 1) := Nat.le_mul_of_pos_right _ (by omega) + calc c₀ * (B * (s a + 1) + (2 * K * (B' * (s a + 1)) + K) + (enc (f a)).length + 1) + ≤ c₀ * (B * (s a + 1) + (2 * K * (B' * (s a + 1)) + K * (s a + 1)) + + (s a + 1) + (s a + 1)) := Nat.mul_le_mul_left _ (by omega) + _ = c₀ * (B + 2 * K * B' + K + 2) * (s a + 1) := by ring + _ ≤ _ := Nat.mul_le_mul_right _ (by omega) + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean new file mode 100644 index 0000000000..81db2e2807 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/ConfigBound.lean @@ -0,0 +1,354 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas +public import Mathlib.Data.Fintype.BigOperators +public import Mathlib.Data.Fintype.Pi +public import Mathlib.Data.Fintype.Prod +public import Mathlib.Data.Fintype.Option +public import Mathlib.Data.Set.Card +public import Mathlib.Order.Lattice.Nat +public import Mathlib.Algebra.Order.BigOperators.GroupWithZero.Finset +public import Mathlib.Tactic.Ring + +/-! +# Bounds on the number of reachable configurations in bounded space + +A multi-tape Turing machine that uses at most `s` cells of work-tape space can only reach a number +of configurations that differ in their storage content (state and work tapes) that is bounded +exponentially in `s`. Together with the `n + 2` possible positions of the input head this bounds +the number of configurations the machine can be in, disregarding the write-only output tape. + +## Important Definitions + +The results are layered, from the purely combinatorial to the machine-specific: + +* `MultiTapeTM.encard_fitsIn_le` is a counting statement about the type `Storage` alone and does + not mention Turing machines: a memory whose non-blank cells and heads stay within per-tape + windows of total size `s` can hold at most `storageBound Symbol State k s` different values. +* `MultiTapeTM.storage_fitsIn` is the geometric input: the storage reached after `t` steps stays + within the windows given by the space used up to step `t`. +* `MultiTapeTM.encard_storages_le` combines the two: a machine bounded by space `s` passes through + at most `storageBound Symbol State k s` storages *during its whole run*, no matter how long it + runs and how long its input is. This is the form needed for arguments below logarithmic space, + where the number of storages is much smaller than the number of input head positions. +* `MultiTapeTM.encard_cores_le` adds the input head position, giving the bound + `(n + 2) * storageBound Symbol State k s` on the number of reachable *cores* (`Cfg.core`, + a configuration without its output tape) for an input of length `n`. +* `MultiTapeTM.storageBound_le_base_mul_pow` restates `storageBound Symbol State k s` as + `storageBoundBase Symbol State k * 2 ^ (storageBoundExp Symbol k * s)`, so that the bounds can + be used to time-bound space-bounded machines. + +## Design + +The write-only output tape is never read by `step`, so it can be dropped: what a machine can still +react to is its `Cfg.core`, the pair of the input head position and the `Storage`. The input head +position, in contrast, *is* read, so it cannot be dropped and has to be counted, which is where +the factor `n + 2` comes from (the input head may move one step off the input in either direction). + +Starting from the all-blank tapes with every head at `0` and moving by at most one cell per step, +a computation in which tape `i` has visited at most `sᵢ` cells keeps that tape's head position and +every non-blank cell within the per-tape window `[-sᵢ, sᵢ]`. + +Hence a storage is determined by finite data over these windows, and counting it gives the +per-tape product `∏ᵢ (2 sᵢ + 1) · (|Symbol| + 1)^(2 sᵢ + 1)`. Since the tapes share the total space +budget (`∑ᵢ sᵢ ≤ s`), this collapses to an expression with the *total* space (`2s + k`) as the +alphabet exponent. + +We lose a factor of `2 * k` by simplifying the windows to `[-sᵢ, sᵢ]` instead of the actually used +area, but this is absorbed by the `O(s)` exponent in the final bound. + +The windows for a whole run are available because a machine that is space-bounded at every point in +time attains its per-tape space usage at a single step (`MultiTapeTM.exists_spaceUsedByTape_max`). +-/ + +@[expose] public section + +namespace Turing + +variable {k : ℕ} +variable {State Symbol : Type*} +variable {input : List Symbol} +variable {tm : MultiTapeTM k Symbol State} + +/-! +## Storage + +Defines the core data structure for this file, `Storage`, which contains the state and the work +tapes of a multi-tape Turing machine, with the work tape cells indexed over all of `ℤ`. It is +thus equivalent to a projection of `Cfg`. + +Then `BoundedStorage` is introduced, which restricts the cells and the head position of each tape +to a window `[-s, s]` (with a different `s` for each tape) and is therefore a finite type. It is +proven that the restriction map is injective on those `Storage`s whose non-blank cells and head +positions all lie inside the `[-s, s]` windows, so that counting `BoundedStorage` bounds the +number of such `Storage`s. +-/ + +/-- The state and work-tape data of a machine. -/ +@[ext] +structure Storage (Symbol State : Type*) (k : ℕ) where + /-- the state of the TM (cf. `Cfg.state`) -/ + state : Option State + /-- the contents of work tape `i` (cf. `Cfg.workTapes`) -/ + workTapes (i : Fin k) : ℤ → Option Symbol + /-- the position of the head on work tape `i` (cf. `Cfg.workTapePos`) -/ + workTapePos (i : Fin k) : ℤ + +/-- The window `[-s, s]` of tape positions allotted to a tape that uses `s` cells. -/ +@[scoped grind =] +def window (s : ℕ) : Finset ℤ := Finset.Icc (-(s : ℤ)) s + +@[scoped grind =] +lemma mem_window {s : ℕ} {z : ℤ} : z ∈ window s ↔ z.natAbs ≤ s := by + grind + +@[simp] +lemma card_window (s : ℕ) : (window s).card = 2 * s + 1 := by + grind [Int.card_Icc] + +/-- A bounded storage: the state and work-tape data of a machine, but with the cells and the head +position of tape `i` restricted to the finite window `[-(w i), w i]`. -/ +abbrev BoundedStorage (Symbol State : Type*) {k : ℕ} (w : Fin k → ℕ) := + Option State × ((i : Fin k) → window (w i) → Option Symbol) × ((i : Fin k) → window (w i)) + +/-- A storage fits in the per-tape windows `w`: on each tape `j`, the head position and every +non-blank cell have absolute value `≤ w j`. -/ +structure Storage.FitsIn (x : Storage Symbol State k) (w : Fin k → ℕ) : Prop where + /-- the head position on every tape lies within its window -/ + pos_le : ∀ j, (x.workTapePos j).natAbs ≤ w j + /-- every non-blank cell on every tape lies within its window -/ + cell_le : ∀ j z, x.workTapes j z ≠ none → z.natAbs ≤ w j + +/-- If a `Storage` fits in a smaller window, it also fits in the larger window. -/ +lemma Storage.FitsIn_mono {x : Storage Symbol State k} : Monotone x.FitsIn := by + intro w₁ w₂ h_le h_fits + refine ⟨?_, ?_⟩ + · intro j + exact (h_fits.pos_le j).trans (h_le j) + · intro j z h_ne + exact (h_fits.cell_le j z h_ne).trans (h_le j) + +/-- Restriction of a storage to the finite windows `w` (with heads outside their window +clamped to `0`). -/ +def Storage.toBounded (x : Storage Symbol State k) (w : Fin k → ℕ) : + BoundedStorage Symbol State w := + (x.state, fun j z => x.workTapes j z.1, + fun j => if h : x.workTapePos j ∈ window (w j) then ⟨x.workTapePos j, h⟩ + else ⟨0, mem_window.mpr (Nat.zero_le _)⟩) + +/-- The restriction is injective on storages that fit in the windows. -/ +lemma Storage.toBounded_injOn (w : Fin k → ℕ) : + Set.InjOn (Storage.toBounded (Symbol := Symbol) (State := State) · w) {x | x.FitsIn w} := by + rintro x ⟨_, _⟩ y ⟨_, _⟩ hxy + simp only [Storage.toBounded, Prod.mk.injEq] at hxy + obtain ⟨hstate, htapes, hpos⟩ := hxy + apply Storage.ext hstate (funext₂ fun j z => ?_) (funext fun j => ?_) + · by_cases hz : z ∈ window (w j) + · exact congrFun (congrFun htapes j) ⟨z, hz⟩ + · grind + · grind [congrFun hpos j] + +/-! ## Counting storages + +This section is purely combinatorial: it counts how many values a `Storage` restricted to given +windows can take, without reference to a machine or a run. +-/ + +/-- An upper bound on the number of storages a `k`-tape machine can be in while using +at most `s` cells of total work-tape space, over the given alphabet and state set. The `(2s + 1)^k` +factor counts the possible head positions; the dominant factor `(|Symbol| + 1)^(2s + k)` uses the +*total* space `s` in the exponent (the `k` tapes share the space budget). -/ +def storageBound (Symbol State : Type*) [Fintype Symbol] [Fintype State] (k s : ℕ) : ℕ := + (Fintype.card State + 1) * ((2 * s + 1) ^ k * (Fintype.card Symbol + 1) ^ (2 * s + k)) + +/-- The number of bounded storages is at most `storageBound`. Counting the tapes separately gives +the per-tape product `∏ᵢ (2 wᵢ + 1) · (|Symbol| + 1) ^ (2 wᵢ + 1)`; each tape uses at most the +total space `s`, and the tapes together use at most `s`, which collapses the alphabet exponent +to `2s + k`. -/ +lemma card_boundedStorage_le [Fintype Symbol] [Fintype State] + {w : Fin k → ℕ} {s : ℕ} (hsum : ∑ i, w i ≤ s) : + Fintype.card (BoundedStorage Symbol State w) ≤ storageBound Symbol State k s := by + have hle : ∀ i, w i ≤ s := fun i => + (Finset.single_le_sum (fun i _ => Nat.zero_le (w i)) (Finset.mem_univ i)).trans hsum + simp only [BoundedStorage, storageBound, Fintype.card_prod, Fintype.card_option, + Fintype.card_pi, Finset.prod_const, Finset.card_univ, Fintype.card_coe, card_window] + rw [mul_comm (∏ i, (Fintype.card Symbol + 1) ^ (2 * w i + 1)), Finset.prod_pow_eq_pow_sum] + have hsc : ∑ i : Fin k, (2 * w i + 1) = 2 * (∑ i, w i) + k := by + simp [two_mul, Finset.sum_add_distrib] + gcongr + · simpa using Finset.prod_le_pow_card Finset.univ (fun i => 2 * w i + 1) (2 * s + 1) + fun i _ => by have := hle i; omega + · omega + · omega + +/-- The counting result at the heart of this file: a `Storage` whose non-blank cells and head +positions stay within per-tape windows of total size at most `s` can take at most +`storageBound Symbol State k s` different values. -/ +theorem encard_fitsIn_le [Fintype Symbol] [Fintype State] + {w : Fin k → ℕ} {s : ℕ} (hsum : ∑ i, w i ≤ s) : + {x : Storage Symbol State k | x.FitsIn w}.encard + ≤ storageBound Symbol State k s := by + calc {x : Storage Symbol State k | x.FitsIn w}.encard + = ((Storage.toBounded · w) '' {x | x.FitsIn w}).encard := + ((Storage.toBounded_injOn w).encard_image).symm + _ ≤ (Set.univ : Set (BoundedStorage Symbol State w)).encard := + Set.encard_le_encard (Set.subset_univ _) + _ = Fintype.card (BoundedStorage Symbol State w) := by + simp [Set.encard_univ, ENat.card_eq_coe_fintype_card] + _ ≤ storageBound Symbol State k s := by + exact_mod_cast card_boundedStorage_le hsum + +/-! ### The exponential form of `storageBound` + +This proves that `storageBound` is exponential in the space `s`. + -/ + +/-- The base factor in the resulting exponential form of `storageBound`. -/ +def storageBoundBase (Symbol State : Type*) [Fintype Symbol] [Fintype State] (k : ℕ) : ℕ := + (Fintype.card State + 1) * 2 ^ ((Fintype.card Symbol + 1) * k + k) + +/-- The factor in the exponent of the exponential form of `storageBound`. -/ +def storageBoundExp (Symbol : Type*) [Fintype Symbol] (k : ℕ) : ℕ := + 2 * (Fintype.card Symbol + 1) + k + +/-- `storageBound` grows at most exponentially in the space `s`, with a constant factor and a +factor in the exponent that only depend on the machine's alphabet, state set and tape count. -/ +lemma storageBound_le_base_mul_pow [Fintype Symbol] [Fintype State] (s : ℕ) : + storageBound Symbol State k s + ≤ storageBoundBase Symbol State k * 2 ^ (storageBoundExp Symbol k * s) := by + set syms := Fintype.card Symbol + 1 with hB + set states := Fintype.card State + 1 with hQ + -- The strategy is to bound each factor of `storageBound` by a power of `2`, using + -- `syms ≤ 2 ^ syms` and `2 * s + 1 ≤ 2 ^ (s + 1)`. Collecting the exponents then yields + -- `(s + 1) * k + syms * (2 * s + k)`, which splits into the constant part `syms * k + k` + -- (which is in `storageBoundBase`) and the part `(2 * syms + k) * s` linear in `s`. + have hB2 : syms ≤ 2 ^ syms := Nat.lt_two_pow_self.le + have h2s1 : 2 * s + 1 ≤ 2 ^ (s + 1) := by grind [pow_succ, Nat.lt_two_pow_self] + calc storageBound Symbol State k s + = states * ((2 * s + 1) ^ k * syms ^ (2 * s + k)) := rfl + _ ≤ states * ((2 ^ (s + 1)) ^ k * (2 ^ syms) ^ (2 * s + k)) := by gcongr <;> omega + _ = states * 2 ^ ((s + 1) * k + syms * (2 * s + k)) := by ring + _ = states * 2 ^ ((syms * k + k) + (2 * syms + k) * s) := by ring_nf + _ = states * 2 ^ (syms * k + k) * 2 ^ ((2 * syms + k) * s) := by ring + +/-- `storageBound` grows at most exponentially in the space `s`: there exist constants `a` and `c` +(depending on the machine's alphabet, state set and tape count) with +`storageBound Symbol State k s ≤ a * 2 ^ (c * s)` for all `s`. -/ +lemma storageBound_le_pow [Fintype Symbol] [Fintype State] : + ∃ a c : ℕ, ∀ s : ℕ, storageBound Symbol State k s ≤ a * 2 ^ (c * s) := + ⟨_, _, storageBound_le_base_mul_pow⟩ + +/-! ## The storage and the core of a configuration + +Now we relate `Cfg` and `Storage` by giving the projection. +-/ + +/-- This function maps a `Cfg` to `Storage`, forgetting the input head position and the +write-only output tape. -/ +def Cfg.storage (c : Cfg k Symbol State input) : Storage Symbol State k := + ⟨c.state, c.workTapes, c.workTapePos⟩ + +/-- The part of a configuration that the machine can still read: the input head position together +with the `Storage`, i.e. the configuration without the write-only output tape. -/ +def Cfg.core (c : Cfg k Symbol State input) : + Fin (input.length + 2) × Storage Symbol State k := + (c.inputPos, c.storage) + +/-- `step` never reads the output tape, so the core of the next configuration is determined by the +core of the current one. -/ +lemma core_step_eq_of_core_eq {c₁ c₂ : Cfg k Symbol State input} (h : c₁.core = c₂.core) : + (tm.step c₁).core = (tm.step c₂).core := by + simp only [Cfg.core, Cfg.storage, Prod.mk.injEq, Storage.mk.injEq] at h + obtain ⟨hpos, hstate, hwt, hwp⟩ := h + have hsym : c₁.inputSymbol = c₂.inputSymbol := by simp [Cfg.inputSymbol, hpos] + have hws : c₁.workTapeSymbols = c₂.workTapeSymbols := by + funext i + simp [Cfg.workTapeSymbols, hwt, hwp] + simp only [Cfg.core, Cfg.storage, MultiTapeTM.step, hstate, hsym, hws] + cases c₂.state <;> simp [hpos, hstate, hwt, hwp] + +/-! ## The storages and cores of a space-bounded run + +These are the main results giving upper bounds on the number of storages and configuration cores +reachable in bounded space. +-/ + +namespace MultiTapeTM + +/-- The storage reached after `t` steps fits in the windows given by the per-tape space usage up +to step `t`. -/ +lemma storage_fitsIn (t : ℕ) : + (tm.runFrom (tm.initCfg input) t).storage.FitsIn (tm.spaceUsedByTape (tm.initCfg input) t) := by + constructor + · intro j + simpa [Cfg.storage] using tm.natAbs_le_spaceUsedByTape_of_mem_visited + (tm.mem_visitedByTapeHead_self (tm.initCfg input) t j) + · intro j + exact content_natAbs_le_spaceUsedByTape t + +/-- A machine that uses at most `s` cells of work-tape space at every point in time passes through +at most `storageBound Symbol State k s` different storages during its whole run — independently of +the length of the input and of how long it runs. -/ +theorem encard_storages_le [Fintype Symbol] [Fintype State] {s : ℕ} + (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) : + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage).encard + ≤ storageBound Symbol State k s := by + obtain ⟨T, hT⟩ := tm.exists_spaceUsedByTape_max (tm.initCfg input) hs + refine le_trans (Set.encard_le_encard ?_) (encard_fitsIn_le (hs T)) + rintro _ ⟨t, rfl⟩ + exact Storage.FitsIn_mono (fun i => hT t i) (tm.storage_fitsIn t) + +/-- The number of configuration cores that a machine bounded by space `s` can reach is at most +`(n + 2) * storageBound Symbol State k s`, where `n` is the length of the input. -/ +theorem encard_cores_le [Fintype Symbol] [Fintype State] {s : ℕ} + (hs : ∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) : + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).core).encard + ≤ (input.length + 2) * storageBound Symbol State k s := by + calc (Set.range fun t => (tm.runFrom (tm.initCfg input) t).core).encard + ≤ ((Set.univ : Set (Fin (input.length + 2))) + ×ˢ (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage)).encard := by + apply Set.encard_le_encard + rintro _ ⟨t, rfl⟩ + exact ⟨Set.mem_univ _, t, rfl⟩ + _ = (Set.univ : Set (Fin (input.length + 2))).encard + * (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage).encard := Set.encard_prod + _ ≤ (input.length + 2) * storageBound Symbol State k s := by + refine mul_le_mul' ?_ (tm.encard_storages_le hs) + simp [Set.encard_univ, ENat.card_eq_coe_fintype_card] + +/-- The storage bound in exponential form: the number of storages a space-`s`-bounded machine +passes through is at most `2 ^ (O(s))`, with constants depending only on the machine. -/ +theorem encard_storages_le_pow [Finite Symbol] [Finite State] : + ∃ a c : ℕ, ∀ (input : List Symbol) (s : ℕ), + (∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) → + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).storage).encard ≤ a * 2 ^ (c * s) := by + have : Fintype Symbol := Fintype.ofFinite Symbol + have : Fintype State := Fintype.ofFinite State + obtain ⟨a, c, hpow⟩ := storageBound_le_pow (Symbol := Symbol) (State := State) (k := k) + refine ⟨a, c, fun input s hs => (tm.encard_storages_le hs).trans ?_⟩ + exact_mod_cast hpow s + +/-- The core bound in exponential form: the number of cores a space-`s`-bounded machine can reach +is at most `(n + 2) * 2 ^ (O(s))`, with constants depending only on the machine and not on the +input. -/ +theorem encard_cores_le_pow [Finite Symbol] [Finite State] : + ∃ a c : ℕ, ∀ (input : List Symbol) (s : ℕ), + (∀ t, tm.spaceUsed (tm.initCfg input) t ≤ s) → + (Set.range fun t => (tm.runFrom (tm.initCfg input) t).core).encard + ≤ (input.length + 2) * a * 2 ^ (c * s) := by + have : Fintype Symbol := Fintype.ofFinite Symbol + have : Fintype State := Fintype.ofFinite State + obtain ⟨a, c, hpow⟩ := storageBound_le_pow (Symbol := Symbol) (State := State) (k := k) + refine ⟨a, c, fun input s hs => (tm.encard_cores_le hs).trans ?_⟩ + calc ((input.length + 2) * storageBound Symbol State k s : ℕ∞) + ≤ ((input.length + 2) * (a * 2 ^ (c * s)) : ℕ) := by + exact_mod_cast Nat.mul_le_mul_left _ (hpow s) + _ = (input.length + 2) * a * 2 ^ (c * s) := by push_cast; ring + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean index 93e8aa70fb..83494f5ab3 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Configuration.lean @@ -81,6 +81,14 @@ structure Cfg (k : ℕ) (Symbol State : Type*) (input : List Symbol) where output : List Symbol deriving Inhabited +/-- Two configurations with no work tapes are equal when their state, input head and output +agree. -/ +lemma Cfg.ext_zero_tapes {Symbol State : Type*} {input : List Symbol} + {cfg₁ cfg₂ : Cfg 0 Symbol State input} (state : cfg₁.state = cfg₂.state) + (inputPos : cfg₁.inputPos = cfg₂.inputPos) (output : cfg₁.output = cfg₂.output) : + cfg₁ = cfg₂ := + Cfg.ext state inputPos (funext fun i => i.elim0) (funext fun i => i.elim0) output + /-- Attempt to move the input tape head. The machine can only read one empty cell outside of the input, any attempted movement beyond that results in no movement. @@ -128,12 +136,45 @@ lemma moveInputPos_pos_of_ne_right {n : ℕ} (p : Fin (n + 2)) (h : p.val ≠ n · simp omega +/-- The input head moves by at most one position. -/ +lemma val_moveInputPos_le {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : + (moveInputPos pos m).val ≤ pos.val + 1 := by + simp only [moveInputPos] + by_cases h : (((pos.val : ℤ) + m.cast).toNat) < n + 2 + · rw [dite_eq_left h] + rcases m <;> (simp only [SignType.cast]; omega) + · rw [dite_eq_right h] + have := pos.isLt + rcases m <;> (simp only [SignType.cast] at h; omega) + +/-- The value of the input head after a move, as a clamped integer. `omega`-friendly. -/ +lemma val_moveInputPos_eq {n : ℕ} (pos : Fin (n + 2)) (m : SignType) : + ((moveInputPos pos m).val : ℤ) = min ((n : ℤ) + 1) (max 0 ((pos.val : ℤ) + (m.cast : ℤ))) := by + simp only [moveInputPos] + have hmc : (m.cast : ℤ) = -1 ∨ (m.cast : ℤ) = 0 ∨ (m.cast : ℤ) = 1 := by + rcases m with _ | _ | _ <;> simp [SignType.cast] + by_cases h : (((pos.val : ℤ) + (m.cast : ℤ)).toNat) < n + 2 + · rw [dite_eq_left h] + have := pos.isLt + push_cast + omega + · rw [dite_eq_right h] + have := pos.isLt + push_cast + omega + /-- The symbol currently under the input tape head. -/ def Cfg.inputSymbol (cfg : Cfg k Symbol State input) : Option Symbol := if h₁ : cfg.inputPos = 0 then none else if h₂ : cfg.inputPos = input.length + 1 then none else input[cfg.inputPos.val - 1]'(by grind) +/-- At either boundary of the input, the head reads a blank. -/ +lemma inputSymbol_eq_none_of_boundary {cfg : Cfg k Symbol State input} + (h : cfg.inputPos.val = 0 ∨ cfg.inputPos.val = input.length + 1) : + cfg.inputSymbol = none := by + grind [Cfg.inputSymbol] + @[simp] lemma inputSymbolInner {cfg : Cfg k Symbol State input} (p : ℕ) (h₁ : cfg.inputPos.val = 1 + p) @@ -148,6 +189,24 @@ def Cfg.workTapeSymbols (cfg : Cfg k Symbol State input) (i : Fin k) : Option Sy /-- A configuration is halted when it has no state to continue from. -/ abbrev Cfg.Halted (cfg : Cfg k Symbol State input) : Prop := cfg.state = none +/-- The same configuration with a different output tape. -/ +@[simps] def Cfg.withOutput (c : Cfg k Symbol State input) (out : List Symbol) : + Cfg k Symbol State input := + ⟨c.state, c.inputPos, c.workTapes, c.workTapePos, out⟩ + +/-- The same configuration in a different control state, possibly of a different state type. -/ +@[simps] def Cfg.withState (cfg : Cfg k Symbol State input) + {State' : Type*} (q : Option State') : Cfg k Symbol State' input := + ⟨q, cfg.inputPos, cfg.workTapes, cfg.workTapePos, cfg.output⟩ + +/-- Remap the (optional) state of a configuration through `φ`, leaving the input head, the work +tapes, the work-tape heads and the output alone. The control-flow combinators (`seq`, `branch`, +`repeat`) embed a sub-machine's configurations into the combined machine by exactly such a state +remap. -/ +@[simps] def Cfg.mapState {State' : Type*} (φ : Option State → Option State') + (c : Cfg k Symbol State input) : Cfg k Symbol State' input := + ⟨φ c.state, c.inputPos, c.workTapes, c.workTapePos, c.output⟩ + /-- The initial configuration for a starting state and an input string. -/ @[simp] def Cfg.init (q₀ : State) (input : List Symbol) : Cfg k Symbol State input := diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean index 602953c797..fb22603bb3 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/Deterministic.lean @@ -191,6 +191,26 @@ lemma runFrom_of_halt (cfg : Cfg k Symbol State input) (h : cfg.state = none) {n tm.runFrom cfg n = cfg := Function.iterate_fixed (step_of_halt h) n +/-- Nothing changes after the machine has halted. -/ +lemma runFrom_eq_of_halt + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) {τ t : ℕ} (hle : τ ≤ t) + (hhalt : (tm.runFrom cfg τ).state = none) : + tm.runFrom cfg t = tm.runFrom cfg τ := by + conv_lhs => rw [← Nat.sub_add_cancel hle, Nat.add_comm] + rw [runFrom_add, runFrom_of_halt _ hhalt] + +/-- Every halted run has a first halting time no later than the supplied one. -/ +lemma exists_minimal_halting_time + (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) + (hhalt : (tm.runFrom cfg t).state = none) : + ∃ u ≤ t, (tm.runFrom cfg u).state = none ∧ ∀ s < u, (tm.runFrom cfg s).state ≠ none := by + classical + have hex : ∃ n, (tm.runFrom cfg n).state = none := ⟨t, hhalt⟩ + exact ⟨Nat.find hex, Nat.find_min' hex hhalt, Nat.find_spec hex, + fun s hs => Nat.find_min hex hs⟩ + @[simp] lemma outputSymbol_of_halt {cfg : Cfg k Symbol State input} (h_halt : cfg.state = none) : tm.outputSymbol cfg = none := by @@ -267,6 +287,24 @@ lemma step_output (cfg : Cfg k Symbol State input) : unfold step outputSymbol Action.apply cases cfg.state <;> simp +/-- The input head strays at most `t` positions from where it started in `t` steps. -/ +lemma inputPos_runFrom_le (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) : + ((tm.runFrom cfg t).inputPos : ℕ) ≤ (cfg.inputPos : ℕ) + t := by + induction t with + | zero => simp + | succ t ih => + rw [runFrom_succ_eq_step'] + by_cases hq : (tm.runFrom cfg t).state = none + · rw [step_of_halt hq] + omega + · obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp hq + have h : ((tm.step (tm.runFrom cfg t)).inputPos : ℕ) ≤ + ((tm.runFrom cfg t).inputPos : ℕ) + 1 := by + simp only [step, hq, Action.apply] + exact val_moveInputPos_le _ _ + omega + /-- The output does not change after the machine has halted. -/ lemma runFrom_output_eq_of_halt (tm : MultiTapeTM k Symbol State) @@ -332,6 +370,31 @@ theorem ComputableInTimeAndSpace.mono {α β : Type*} obtain ⟨k, State, hfinite, tm, htm⟩ := h exact ⟨k, State, hfinite, tm, htm.mono ht hs⟩ +theorem length_output_runFrom_le (tm : MultiTapeTM k Symbol State) + (cfg : Cfg k Symbol State input) (t : ℕ) : + (tm.runFrom cfg t).output.length ≤ cfg.output.length + t := by + induction t with + | zero => simp + | succ t ih => + rw [runFrom_succ_eq_step', step_output, List.length_append] + have : (tm.outputSymbol (tm.runFrom cfg t)).toList.length ≤ 1 := by + cases tm.outputSymbol (tm.runFrom cfg t) <;> simp + omega + +/-- A machine emits at most one symbol per step, so the encoded result of a computation is no +longer than its time bound. This is the only bound available on the length of an intermediate +result: a machine can produce an output much longer than the space it uses. -/ +theorem ComputableInTimeAndSpace.length_encOut_le {α β : Type*} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {f : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace f encIn encOut t s) (a : α) : + (encOut (f a)).length ≤ t a := by + obtain ⟨k, State, _, tm, htm⟩ := h + obtain ⟨t', ht', s', _, _, hout, _⟩ := htm a + have hlen := length_output_runFrom_le tm (tm.initCfg (encIn a)) t' + rw [hout] at hlen + have h0 : (tm.initCfg (encIn a)).output.length = 0 := rfl + omega + open Classical in /-- The Boolean indicator function of a set. -/ noncomputable def indicator {α : Type*} (L : Set α) : α → Bool := diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Encodings/Option.lean b/Cslib/Computability/Machines/Turing/MultiTape/Encodings/Option.lean new file mode 100644 index 0000000000..422160ef54 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Encodings/Option.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant + +/-! +# Encodings of `Option` + +A combinator that produces or consumes an `Option` should not prescribe how `Option α` is encoded. +It is enough that the encoding relates to the encoding of `α` in the way one would expect of a +tagged union: the constructor `some` and its destructor are computable in linear time and zero +space, i.e. by streaming the input to the output without using a work tape. + +The constructor is stated as computability of `Option.some` itself. There is no such function for +the destructor, since a total function `Option α → α` would need a junk value at `none`. Instead, +the destructor is stated as computability of the identity of `α`, read at the encoding of `α` +induced by `encOpt` via `some` on the input side and at `enc` on the output side. This says exactly +that the encoding of `some a` can be turned into the encoding of `a`, and says nothing about +encodings of `none`. + +A subtype `{o : Option α // o.isSome}` would be another way of expressing this, but it is not +needed for composability: computability only depends on the bit strings `encIn a` and +`encOut (f a)`, so by `ComputableInTimeAndSpace.congr` a machine computing `body : α → Option α` +is, on the inputs where the result is `some x`, a machine computing `x` at the encoding +`Function.Embedding.some.trans encOpt`, which is exactly the input encoding of the destructor. The +subtype would drag `Subtype.val` embeddings and `isSome` proofs through every statement without +buying anything. + +Testing an encoded value for `none` is *not* a requirement: `fun o => o.isNone` is constant except +at the single argument `none`, so it is computable in constant time and zero space for every +encoding, by `computableInTimeAndSpace_of_exists_finite_ne`. + +## Main definitions + +* `Turing.MultiTapeTM.IsOptionEncoding`: the requirements on an encoding of `Option α` relative to + an encoding of `α`. +* `Turing.MultiTapeTM.encOption`: the canonical encoding of `Option α`, which prefixes the encoding + of the value with a tag bit. + +## Main results + +* `Turing.MultiTapeTM.computableInTimeAndSpace_isNone`: testing for `none` is computable in + constant time and zero space, for every encoding. +* `Turing.MultiTapeTM.isOptionEncoding_encOption`: the canonical encoding satisfies the + requirements. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α : Type*} + +/-- The requirements on an encoding `encOpt` of `Option α`, relative to an encoding `enc` of `α`: +the constructor `some` and its destructor are computable in linear time and zero space. -/ +public structure IsOptionEncoding (enc : α ↪ List Bool) (encOpt : Option α ↪ List Bool) : Prop where + /-- The constructor `some` is computable in linear time and zero space. -/ + constructor_computable : ∃ c, ComputableInTimeAndSpace (Option.some : α → Option α) enc encOpt + (fun a => c * ((enc a).length + 1)) (fun _ => 0) + /-- The destructor of `some` is computable in linear time and zero space. Note that this only + constrains the encodings of values of the form `some a`. -/ + destructor_computable : ∃ c, ComputableInTimeAndSpace (id : α → α) + (Function.Embedding.some.trans encOpt) enc + (fun a => c * ((encOpt (some a)).length + 1)) (fun _ => 0) + +/-- Testing an encoded value for `none` is computable in constant time and zero space, for every +encoding of `Option α`, since the function is constant except at the single argument `none`. -/ +public theorem computableInTimeAndSpace_isNone {encOpt : Option α ↪ List Bool} + {encBool : Bool ↪ List Bool} : + ∃ c, ComputableInTimeAndSpace (fun o : Option α => o.isNone) encOpt encBool + (fun _ => c) (fun _ => 0) := + computableInTimeAndSpace_of_exists_finite_ne ⟨false, + Set.Finite.subset (Set.finite_singleton none) (by rintro (_ | a) ha <;> simp_all)⟩ + +/-- The canonical encoding of `Option α`: a tag bit, followed by the encoding of the value. -/ +public def encOption (enc : α ↪ List Bool) : Option α ↪ List Bool where + toFun + | none => [false] + | some a => true :: enc a + inj' := by rintro (_ | a) (_ | b) h <;> simp_all + +/-- The canonical encoding of `Option α` satisfies the requirements: the constructor emits a `true` +and then copies its input, the destructor drops the `true` and copies the rest. -/ +proof_wanted isOptionEncoding_encOption {enc : α ↪ List Bool} : + IsOptionEncoding enc (encOption enc) + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean new file mode 100644 index 0000000000..b9958923ae --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Adapters.lean @@ -0,0 +1,801 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.OutputToTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.InputFromTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.EmitTape +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.ExtendTapes + +/-! +# From a computable function to a tape transformer + +A computable function enters the word-transformer interface +(`Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes`) by three steps: make it +*tidy* (`Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy`), so it halts with its +result on the append-only output tape and everything else blank; *redirect that output to a work +tape* (`outputToTape`), which leaves the result on a fresh last tape with the head at the write +frontier; and *rewind that head* (`rewindTape`) so the tape holds a word in the normal form the +interface expects. + +`exists_transformsTapes_ofComputableInput` is the resulting adapter for a function read from the +real input tape. The output tape is the last of `k₀ + 1` work tapes, where `k₀` is the tidy +machine's tape count. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_ofComputableInput`: evaluate a computable function, + reading its argument from the real input tape, as a tape transformer on any large-enough layout. +* `Turing.MultiTapeTM.exists_transformsTapes_ofComputable`: the same, reading the argument from a + work tape. +* `Turing.MultiTapeTM.computableInTimeAndSpace_of_transformsTapes`: turn a tape transformer whose + result lands on one work tape back into a computable function, by emitting that tape. +* `Turing.MultiTapeTM.transformsTapes_extendTapes`: a tape transformer stays one after its tapes are + reindexed into a larger layout. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {α β : Type*} + +/-- **A computable function, read from the input tape, as a tape transformer.** Started with the +input on the real input tape and every work tape blank, the machine halts having written the +encoded result to the last work tape, in linear time and in space linear in the result length. -/ +private theorem exists_transformsTapes_ofComputableInput_fixed + {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ (c K : ℕ) (o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), + ∀ a, TransformsTapes tm + (fun input ws => input = enc a ∧ ∀ l, ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) (c * (s a + (encOut (g a)).length + 1) + K) := by + classical + obtain ⟨c₀, k₀, State₀, hfin, tm₀, htidy⟩ := exists_tidy h + obtain ⟨SR, hSR, tmR, hR⟩ := exists_rewindTape (Symbol := Bool) (Fin.last k₀) + have := hfin + have := hSR + -- the composed machine: run the tidy machine with its output on a fresh tape, then rewind it + refine ⟨c₀ + k₀ + 4, k₀ + 1, Fin.last k₀, State₀ ⊕ SR, inferInstance, + tm₀.outputToTape.seq tmR, fun a => ?_⟩ + intro input ws out hP + obtain ⟨hinput, hblank⟩ := hP + subst hinput + have hws : ws = fun _ => [] := funext hblank + subst hws + obtain ⟨τ, hτ, htidyrun, htidysp⟩ := htidy a + -- The encoded result is produced by the *original* machine in at most `t a` steps, so it is no + -- longer than `t a` — a fact the tidy interface alone (which only bounds by `τ`) does not give. + have hw_len : (encOut (g a)).length ≤ t a := h.length_encOut_le a + -- Abbreviations: the encoded result `w`, the tidy halting configuration `X`, and the start. + set w := encOut (g a) with hw_def + set X := wordsCfg (enc a) none (fun _ => []) w with hX_def + set cStart := wordsCfg (enc a) (some (tm₀.outputToTape.seq tmR).q₀) (fun _ => []) out + with hcStart_def + -- =================================================================================== + -- Phase 1: run the tidy machine with its output redirected onto the fresh last work tape. + -- =================================================================================== + -- The phase-1 start configuration, expressed through the output-redirection maps. + have hstart1 : cStart.withState (some tm₀.outputToTape.q₀) + = (outCfg (tm₀.initCfg (enc a))).withOutput out := by + rw [hcStart_def, ← initCfg_outputToTape, initCfg_eq_wordsCfg]; rfl + -- Running the redirected machine mirrors the tidy run, ending on `(outCfg X).withOutput out`. + have hc1_run : tm₀.outputToTape.runFrom (cStart.withState (some tm₀.outputToTape.q₀)) τ + = (outCfg X).withOutput out := by + rw [hstart1, runFrom_outputToTape_withOutput, runFrom_outCfg, htidyrun] + set c₁ := (outCfg X).withOutput out with hc1_def + have hc1_state : c₁.state = none := by rw [hc1_def, hX_def]; rfl + -- Replace `τ` by the first halting time `τ'`, which gives phase-1 activity for free. + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time tm₀.outputToTape (cStart.withState (some tm₀.outputToTape.q₀)) τ + (by rw [hc1_run]; exact hc1_state) + have hc1_run' : tm₀.outputToTape.runFrom (cStart.withState (some tm₀.outputToTape.q₀)) τ' = c₁ := + (runFrom_eq_of_halt tm₀.outputToTape _ hτ'le hτ'halt).symm.trans hc1_run + -- The phase-1 space bound: the tidy space, plus one frontier walk over the written output. + have h₁sp : tm₀.outputToTape.spaceUsed (cStart.withState (some tm₀.outputToTape.q₀)) τ' + ≤ c₀ * (s a + 1) + k₀ + (w.length + 1) := by + rw [hstart1, spaceUsed_outputToTape_withOutput] + refine le_trans (spaceUsed_outputToTape tm₀ (tm₀.initCfg (enc a)) τ') ?_ + have hsp' : tm₀.spaceUsed (tm₀.initCfg (enc a)) τ' ≤ c₀ * (s a + 1) + k₀ := + le_trans (spaceUsed_mono tm₀ (tm₀.initCfg (enc a)) hτ'le) htidysp + have houtlen : (tm₀.runFrom (tm₀.initCfg (enc a)) τ').output.length ≤ w.length := by + have hτeq : τ' + (τ - τ') = τ := by omega + have hmono := length_output_mono tm₀ (tm₀.runFrom (tm₀.initCfg (enc a)) τ') (τ - τ') + rw [← runFrom_add, hτeq, htidyrun, hX_def] at hmono + simpa using hmono + omega + -- =================================================================================== + -- Phase 2: rewind the last tape's head from the frontier back to the start of the word. + -- =================================================================================== + have hcs1_state : (c₁.withState (some tmR.q₀)).state = some tmR.q₀ := rfl + have hcs1_tape : (c₁.withState (some tmR.q₀)).workTapes (Fin.last k₀) = tapeOfList w := by + change (outCfg X).workTapes (Fin.last k₀) = tapeOfList w + simp only [outCfg_workTapes_last, hX_def, wordsCfg_output] + have hcs1_pos : (c₁.withState (some tmR.q₀)).workTapePos (Fin.last k₀) = (w.length : ℤ) := by + change (outCfg X).workTapePos (Fin.last k₀) = (w.length : ℤ) + simp only [outCfg_workTapePos_last, hX_def, wordsCfg_output] + obtain ⟨u₂, hu₂, h₂act, h₂halteq, hframe⟩ := + hR (enc a) (c₁.withState (some tmR.q₀)) w hcs1_state hcs1_tape hcs1_pos + -- The phase-2 space bound: the moving head stays in `[-1, w.length]`, every other head is fixed. + have h₂sp : tmR.spaceUsed (c₁.withState (some tmR.q₀)) u₂ ≤ (w.length + 2) + (k₀ + 1) := by + refine le_trans (spaceUsed_le_of_one_moving (c₁.withState (some tmR.q₀)) u₂ (Fin.last k₀) + (-1) (w.length : ℤ) ?_ ?_) ?_ + · exact fun m hm => ⟨(hframe m hm).2.2.2.2.1, (hframe m hm).2.2.2.2.2⟩ + · exact fun m hm j hj => ((hframe m hm).2.2.1 j hj).2 + · have htoNat : ((w.length : ℤ) + 1 - (-1)).toNat = w.length + 2 := by omega + omega + -- =================================================================================== + -- Assemble the two phases and read off the halting configuration and the two bounds. + -- =================================================================================== + obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := + seq_spec (tm₁ := tm₀.outputToTape) (tm₂ := tmR) (c := cStart) + (by rw [hcStart_def]; rfl) hc1_run' hc1_state hτ'act h₁sp h₂halteq rfl h₂act h₂sp + refine ⟨τ' + u₂, ?_, Function.update (fun _ => []) (Fin.last k₀) w, ?_, rfl, ?_⟩ + · -- Time: `τ' + u₂ ≤ τ + (w.length + 3)`, with `τ ≤ c₀·(t a+1)` and `w.length ≤ t a`. + have hτlin : τ ≤ c₀ * (t a + 1) := hτ + have hprod : (c₀ + k₀ + 4) * (t a + 1) = c₀ * (t a + 1) + (k₀ + 4) * (t a + 1) := by + rw [show c₀ + k₀ + 4 = c₀ + (k₀ + 4) from by omega, Nat.add_mul] + have h4 : 4 * (t a + 1) ≤ (k₀ + 4) * (t a + 1) := Nat.mul_le_mul (by omega) (le_refl _) + omega + · -- The composed run halts in the normal-form configuration `wordsCfg`. + rw [hseq_run] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp [Cfg.withState_inputPos, hc1_def, Cfg.withOutput_inputPos, hX_def, outCfg] + · funext l + induction l using Fin.lastCases with + | last => funext z; simp [hc1_def, hX_def] + | cast j => funext z; simp [hc1_def, hX_def] + · funext l + induction l using Fin.lastCases with + | last => simp [hc1_def, hX_def] + | cast j => simp [hc1_def, hX_def] + · simp [Cfg.withState_output, hc1_def, Cfg.withOutput_output] + · -- Space: `s₁' + s₂'` fits the budget `(c₀+k₀+4)·(s a + w.length + 1) + (k₀+1)`. + refine le_trans hseq_sp ?_ + have e1 : c₀ * (s a + 1) ≤ c₀ * (s a + w.length + 1) := Nat.mul_le_mul (le_refl _) (by omega) + have e2 : (k₀ + 4) * (w.length + 1) ≤ (k₀ + 4) * (s a + w.length + 1) := + Nat.mul_le_mul (le_refl _) (by omega) + have e3 : (c₀ + k₀ + 4) * (s a + w.length + 1) + = c₀ * (s a + w.length + 1) + (k₀ + 4) * (s a + w.length + 1) := by + rw [show c₀ + k₀ + 4 = c₀ + (k₀ + 4) from by omega, Nat.add_mul] + have e4 : (k₀ + 4) * (w.length + 1) = (k₀ + 4) * w.length + (k₀ + 4) := by + rw [Nat.mul_add, Nat.mul_one] + have e5 : 4 * w.length ≤ (k₀ + 4) * w.length := Nat.mul_le_mul (by omega) (le_refl _) + omega + +/-- **A computable function, read from a work tape, as a tape transformer.** The virtual input +tape is the work tape `Fin.last (k₀ + 1)` (one past the tidy machine's tapes and its output tape); +the result is written to the tidy machine's output tape `⟨k₀, _⟩`. Started with the input on the +virtual tape and every other work tape blank, the machine halts having written the encoded result +to the output tape, in linear time and space linear in the input and result lengths. + +Built from `exists_transformsTapes_ofComputableInput`'s machine `M₀` (which reads the *real* input +and leaves the result on a work tape): `inputFromTape M₀` redirects `M₀`'s input reading to the +virtual tape, bracketed by two one-cell writes that place and remove the boundary flag `M₀`'s +input redirection needs. -/ +private theorem exists_transformsTapes_ofComputable_fixed + {enc : α ↪ List Bool} {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ (c K : ℕ) (i o : Fin K) (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), + i ≠ o ∧ ∀ a, TransformsTapes tm + (fun _ ws => ws i = enc a ∧ ∀ l, l ≠ i → ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) (c * (s a + (enc a).length + (encOut (g a)).length + 1) + K) := by + classical + -- The base machine `M₀` reads the *real* input tape and leaves `encOut (g a)` on work tape `o₀`. + obtain ⟨c_f, K₀, o₀, State₀, hfin₀, M₀, hM₀⟩ := exists_transformsTapes_ofComputableInput_fixed h + -- Two one-cell writers on the flag tape `⟨K₀ + 1, _⟩`: one places the boundary mark, one clears + -- it. They bracket the redirected run of `M₀` and supply what its input redirection needs. + obtain ⟨SM, hSMfin, setMark, hMark⟩ := + exists_setCell (Symbol := Bool) (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) (some true) + obtain ⟨SC, hSCfin, setClear, hClear⟩ := + exists_setCell (Symbol := Bool) (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) none + have := hfin₀ + have := hSMfin + have := hSCfin + refine ⟨c_f + 2 * K₀ + 12, K₀ + 2, ⟨K₀, by omega⟩, o₀.castAdd 2, SM ⊕ State₀ ⊕ SC, inferInstance, + setMark.seq ((inputFromTape M₀).seq setClear), ?_, fun a => ?_⟩ + · -- The virtual input tape `⟨K₀, _⟩` and the output tape `o₀.castAdd 2` are distinct. + exact Fin.ne_of_val_ne (by have := o₀.isLt; simp; omega) + intro input ws out hP + obtain ⟨hi, hblank⟩ := hP + -- Split any tape index into an inner tape, the virtual input tape, or the flag tape. + have tcase : ∀ l : Fin (K₀ + 2), + (∃ j : Fin K₀, l = j.castAdd 2) ∨ l = ⟨K₀, by omega⟩ ∨ l = ⟨K₀ + 1, by omega⟩ := by + intro l + rcases Nat.lt_trichotomy l.val K₀ with hlt | heq | hgt + · exact Or.inl ⟨⟨l.val, hlt⟩, Fin.ext (by simp)⟩ + · exact Or.inr (Or.inl (Fin.ext (by simpa using heq))) + · have hb := l.isLt + exact Or.inr (Or.inr (Fin.ext (by simp; omega))) + -- Run the base machine on the real input `enc a`, reading off the encoded result and its bounds. + obtain ⟨τ, hτ, ws₀', hM₀run, hws₀', hM₀sp⟩ := hM₀ a (enc a) (fun _ => []) out ⟨rfl, fun _ => rfl⟩ + set w := encOut (g a) with hw_def + set start := wordsCfg input (some (setMark.seq ((inputFromTape M₀).seq setClear)).q₀) ws out + with hstart + -- =================================================================================== + -- Phase 1: place the boundary mark on the flag tape's cell `-1`. + -- =================================================================================== + obtain ⟨u₁, hu₁, h1act, h1eq, h1frame⟩ := + hMark input (start.withState (some setMark.q₀)) rfl (by simp [hstart]) + set C1 := setMark.runFrom (start.withState (some setMark.q₀)) u₁ with hC1 + -- The halting configuration of phase 1, restarted for `M₀`, is exactly `M₀`'s start as the + -- input-redirected machine sees it: the input `enc a` on the virtual tape, the flag marked. + have hAstart : C1.withState (some M₀.q₀) + = inCfg true (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) input := by + rw [h1eq, hstart] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · have hjf : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀ + 1, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + have hji : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + funext z + simp [Cfg.withState_workTapes, inCfg_workTapes_castAdd, wordsCfg_workTapes, + Function.update_of_ne hjf, hblank _ hji] + · funext z + simp [Cfg.withState_workTapes, inCfg_workTapes_vip, wordsCfg_workTapes, hi] + · have hfi : (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by simp) + funext z + rcases eq_or_ne z (-1 : ℤ) with hz | hz + · subst hz + simp [Cfg.withState_workTapes, inCfg_workTapes_flag, Function.update_self] + · simp [Cfg.withState_workTapes, inCfg_workTapes_flag, wordsCfg_workTapes, + Function.update_self, Function.update_of_ne hz, hblank _ hfi, tapeOfList_nil] + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_castAdd, wordsCfg_workTapePos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_vip, wordsCfg_workTapePos, + wordsCfg_inputPos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_flag, wordsCfg_workTapePos, + wordsCfg_inputPos] + -- Phase-1 space: one head walks `[-1, 0]`, every other head is fixed. + have h1sp : setMark.spaceUsed (start.withState (some setMark.q₀)) u₁ ≤ K₀ + 4 := by + refine le_trans (spaceUsed_le_of_one_moving _ u₁ (⟨K₀ + 1, by omega⟩) (-1) 0 + (fun m hm => ⟨(h1frame m hm).2.2.2.1, (h1frame m hm).2.2.2.2⟩) + (fun m hm j hj => ((h1frame m hm).2.2.1 j hj).2)) ?_ + have : ((0 : ℤ) + 1 - (-1)).toNat = 2 := by omega + omega + -- =================================================================================== + -- Phase 2: run `M₀`, redirected to read `enc a` from the virtual tape. + -- =================================================================================== + -- The redirected run mirrors `M₀`'s run, which `hM₀` says lands in `wordsCfg (enc a) none ws₀'`. + have hA_run_tau : (inputFromTape M₀).runFrom (C1.withState (some M₀.q₀)) τ + = inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input := by + rw [hAstart, runFrom_inCfg, hM₀run] + -- Replace `τ` by the first halting time `τ'`, which gives the phase-2 activity for free. + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time (inputFromTape M₀) (C1.withState (some M₀.q₀)) τ + (by rw [hA_run_tau]; rfl) + have h_A : (inputFromTape M₀).runFrom (C1.withState (some M₀.q₀)) τ' + = inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input := + (runFrom_eq_of_halt (inputFromTape M₀) _ hτ'le hτ'halt).symm.trans hA_run_tau + -- Phase-2 space: the base machine's space, plus one frontier walk over the virtual input. + have hA_sp : (inputFromTape M₀).spaceUsed (C1.withState (some M₀.q₀)) τ' + ≤ c_f * (s a + w.length + 1) + K₀ + 2 * ((enc a).length + 2) := by + rw [hAstart] + refine le_trans (spaceUsed_inputFromTape M₀ true + (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) input τ') ?_ + have hmono : M₀.spaceUsed (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) τ' + ≤ M₀.spaceUsed (wordsCfg (enc a) (some M₀.q₀) (fun _ => []) out) τ := + spaceUsed_mono M₀ _ hτ'le + omega + -- =================================================================================== + -- Phase 3: clear the boundary mark from the flag tape's cell `-1`. + -- =================================================================================== + obtain ⟨uB, huB, hBact, hBeq, hBframe⟩ := + hClear input + ((inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input).withState + (some setClear.q₀)) + rfl (by simp [Cfg.withState_workTapePos, inCfg_workTapePos_flag, wordsCfg_inputPos]) + have hB_sp : setClear.spaceUsed + ((inCfg true (wordsCfg (enc a) (none : Option State₀) ws₀' out) input).withState + (some setClear.q₀)) uB + ≤ K₀ + 4 := by + refine le_trans (spaceUsed_le_of_one_moving _ uB (⟨K₀ + 1, by omega⟩) (-1) 0 + (fun m hm => ⟨(hBframe m hm).2.2.2.1, (hBframe m hm).2.2.2.2⟩) + (fun m hm j hj => ((hBframe m hm).2.2.1 j hj).2)) ?_ + have : ((0 : ℤ) + 1 - (-1)).toNat = 2 := by omega + omega + -- =================================================================================== + -- Assemble the three phases (a nested sequential composition) and read off the results. + -- =================================================================================== + obtain ⟨inner_run, inner_act, inner_sp⟩ := + seq_spec (tm₁ := inputFromTape M₀) (tm₂ := setClear) + (c := C1.withState (some ((inputFromTape M₀).seq setClear).q₀)) + rfl h_A rfl hτ'act hA_sp hBeq rfl hBact hB_sp + obtain ⟨outer_run, outer_act, outer_sp⟩ := + seq_spec (tm₁ := setMark) (tm₂ := (inputFromTape M₀).seq setClear) (c := start) + (by rw [hstart]; rfl) hC1.symm (by rw [h1eq]) h1act h1sp inner_run rfl inner_act inner_sp + refine ⟨u₁ + (τ' + uB), ?_, Function.update ws (o₀.castAdd 2) w, ?_, rfl, ?_⟩ + · -- Time: `u₁ + τ' + uB ≤ 4 + c_f·(t a + 1) + 4`, absorbed by the generous constant. + have e : (c_f + 2 * K₀ + 12) * (t a + 1) + = c_f * (t a + 1) + (2 * K₀ + 12) * (t a + 1) := by + rw [show c_f + 2 * K₀ + 12 = c_f + (2 * K₀ + 12) from by omega, Nat.add_mul] + have h8 : 8 * 1 ≤ (2 * K₀ + 12) * (t a + 1) := Nat.mul_le_mul (by omega) (by omega) + omega + · -- The composed run halts in the normal-form configuration, with `w` on the output tape. + rw [outer_run] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · have hjf : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀ + 1, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + have hji : (j.castAdd 2 : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by have := j.isLt; simp; omega) + funext z + simp only [Cfg.withState_workTapes, Function.update_of_ne hjf, inCfg_workTapes_castAdd, + wordsCfg_workTapes, hws₀'] + by_cases hjo : j = o₀ + · subst hjo + simp only [Function.update_self] + · have hjo2 : (j.castAdd 2 : Fin (K₀ + 2)) ≠ o₀.castAdd 2 := + fun hh => hjo (Fin.ext (by simpa using congrArg Fin.val hh)) + simp only [Function.update_of_ne hjo, Function.update_of_ne hjo2, hblank _ hji] + · have hio : (⟨K₀, by omega⟩ : Fin (K₀ + 2)) ≠ o₀.castAdd 2 := + Fin.ne_of_val_ne (by have := o₀.isLt; simp; omega) + have hif : (⟨K₀, by omega⟩ : Fin (K₀ + 2)) ≠ ⟨K₀ + 1, by omega⟩ := + Fin.ne_of_val_ne (by simp) + funext z + simp only [Cfg.withState_workTapes, Function.update_of_ne hif, inCfg_workTapes_vip, + wordsCfg_workTapes, Function.update_of_ne hio, hi] + · have hfo : (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) ≠ o₀.castAdd 2 := + Fin.ne_of_val_ne (by have := o₀.isLt; simp; omega) + have hfi : (⟨K₀ + 1, by omega⟩ : Fin (K₀ + 2)) ≠ ⟨K₀, by omega⟩ := + Fin.ne_of_val_ne (by simp) + funext z + rcases eq_or_ne z (-1 : ℤ) with hz | hz + · subst hz + simp [Cfg.withState_workTapes, wordsCfg_workTapes, + Function.update_self, Function.update_of_ne hfo, hblank _ hfi, tapeOfList_nil] + · simp [Cfg.withState_workTapes, inCfg_workTapes_flag, wordsCfg_workTapes, + Function.update_self, Function.update_of_ne hz, Function.update_of_ne hfo, + hblank _ hfi, tapeOfList_nil] + · funext l + rcases tcase l with ⟨j, rfl⟩ | rfl | rfl + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_castAdd, wordsCfg_workTapePos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_vip, wordsCfg_workTapePos, + wordsCfg_inputPos] + · simp [Cfg.withState_workTapePos, inCfg_workTapePos_flag, wordsCfg_workTapePos, + wordsCfg_inputPos] + · -- Space: the two flag writes plus the redirected run fit the generous budget. + refine le_trans outer_sp ?_ + have eL : (c_f + 2 * K₀ + 12) * (s a + (enc a).length + w.length + 1) + = c_f * (s a + (enc a).length + w.length + 1) + + (2 * K₀ + 12) * (s a + (enc a).length + w.length + 1) := by + rw [show c_f + 2 * K₀ + 12 = c_f + (2 * K₀ + 12) from by omega, Nat.add_mul] + have ecf : c_f * (s a + w.length + 1) + ≤ c_f * (s a + (enc a).length + w.length + 1) := Nat.mul_le_mul (le_refl _) (by omega) + have ebig : (2 * K₀ + 12) * ((enc a).length + 1) + ≤ (2 * K₀ + 12) * (s a + (enc a).length + w.length + 1) := + Nat.mul_le_mul (le_refl _) (by omega) + have eexp : (2 * K₀ + 12) * ((enc a).length + 1) + = (2 * K₀ + 12) * (enc a).length + (2 * K₀ + 12) := by + rw [Nat.mul_add, Nat.mul_one] + have elen : 2 * (enc a).length ≤ (2 * K₀ + 12) * (enc a).length := + Nat.mul_le_mul (by omega) (le_refl _) + omega + +/-- **From a tape transformer back to a computable function.** A machine that, reading the input +from the real input tape with every work tape blank, halts with the encoded result on work tape +`o`, computes that function once the result is copied from tape `o` to the real output tape. -/ +public theorem computableInTimeAndSpace_of_transformsTapes {K : ℕ} {State : Type} [Finite State] + (o : Fin K) {tm : MultiTapeTM K Bool State} + {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} {gg : α → β} {t s : α → ℕ} + (hT : ∀ a, TransformsTapes tm (fun input ws => input = encIn a ∧ ∀ l, ws l = []) + (fun _ _ ws' => ws' o = encOut (gg a)) (t a) (s a)) : + ∃ c, ComputableInTimeAndSpace gg encIn encOut + (fun a => c * (t a + (encOut (gg a)).length + 1)) + (fun a => c * (s a + (encOut (gg a)).length + 1)) := by + obtain ⟨SE, hSE, tmE, hE⟩ := exists_emitTape (Symbol := Bool) o + have := hSE + refine ⟨K + 2, K, State ⊕ SE, inferInstance, tm.seq tmE, fun a => ?_⟩ + -- run the transformer, then emit tape `o` + set start := (tm.seq tmE).initCfg (encIn a) with hstart + have hstart_words : start = wordsCfg (encIn a) (some (tm.seq tmE).q₀) (fun _ => []) [] := by + rw [hstart, initCfg_eq_wordsCfg] + -- phase 1: the transformer halts with the result on tape `o` + obtain ⟨τ, hτ, ws', hrun1, hws', hsp1⟩ := + hT a (encIn a) (fun _ => []) [] ⟨rfl, fun _ => rfl⟩ + have hc1eq : tm.runFrom (start.withState (some tm.q₀)) τ = + wordsCfg (encIn a) none ws' [] := by + rw [hstart_words]; exact hrun1 + -- first halting time of phase 1, for activity + obtain ⟨τ', hτ'le, hτ'halt, hτ'act⟩ := + exists_minimal_halting_time tm (start.withState (some tm.q₀)) τ (by rw [hc1eq]; rfl) + have hc1eq' : tm.runFrom (start.withState (some tm.q₀)) τ' = wordsCfg (encIn a) none ws' [] := + (runFrom_eq_of_halt tm _ hτ'le hτ'halt).symm.trans hc1eq + set c₁ := wordsCfg (encIn a) (none : Option State) ws' [] with hc1def + -- tape `o` holds the encoded result, head at 0 + have ho_tape : c₁.workTapes o = tapeOfList (encOut (gg a)) := by + rw [hc1def] + change tapeOfList (ws' o) = tapeOfList (encOut (gg a)) + rw [hws'] + have ho_pos : c₁.workTapePos o = 0 := by rw [hc1def, wordsCfg_workTapePos] + -- phase 2: emit tape `o` to the output + obtain ⟨u₂, hu₂, h₂act, h₂run, h₂frame⟩ := + hE (encIn a) (c₁.withState (some tmE.q₀)) (encOut (gg a)) rfl ho_tape ho_pos + -- the two phase-space bounds + have hstartws : start.withState (some tm.q₀) = + wordsCfg (encIn a) (some tm.q₀) (fun _ => []) [] := by + rw [hstart_words]; rfl + have hsp1' : tm.spaceUsed (start.withState (some tm.q₀)) τ' ≤ s a := by + rw [hstartws] + exact le_trans (spaceUsed_mono tm _ hτ'le) hsp1 + have hsp2' : tmE.spaceUsed (c₁.withState (some tmE.q₀)) u₂ ≤ + (encOut (gg a)).length + 1 + K := by + refine le_trans (spaceUsed_le_of_one_moving (c₁.withState (some tmE.q₀)) u₂ o + 0 ((encOut (gg a)).length : ℤ) (fun m hm => ⟨(h₂frame m hm).2.2.2.1, + (h₂frame m hm).2.2.2.2⟩) (fun m hm j hj => (h₂frame m hm).2.2.1 j hj)) ?_ + have : ((encOut (gg a)).length + 1 - (0 : ℤ)).toNat = (encOut (gg a)).length + 1 := by omega + omega + -- assemble + obtain ⟨hseq_run, hseq_act, hseq_sp⟩ := + seq_spec (tm₁ := tm) (tm₂ := tmE) (c := start) (by rw [hstart_words]; rfl) + hc1eq' (by rw [hc1def]; rfl) hτ'act hsp1' h₂run rfl h₂act hsp2' + refine ⟨τ' + u₂, ?_, (tm.seq tmE).spaceUsed start (τ' + u₂), ?_, ?_, ?_, rfl⟩ + · -- time bound: τ'+u₂ ≤ t a+|encOut|+2 ≤ (K+2)·(t a+|encOut|+1) + change τ' + u₂ ≤ (K + 2) * (t a + (encOut (gg a)).length + 1) + have hu : u₂ ≤ (encOut (gg a)).length + 2 := hu₂ + have hτt : τ' ≤ t a := le_trans hτ'le hτ + have hprod2 : 2 * (t a + (encOut (gg a)).length + 1) + ≤ (K + 2) * (t a + (encOut (gg a)).length + 1) := Nat.mul_le_mul_right _ (by omega) + omega + · -- space bound: s a + (|encOut|+1+K) ≤ (K+2)·(s a + |encOut| + 1) + change (tm.seq tmE).spaceUsed start (τ' + u₂) ≤ (K + 2) * (s a + (encOut (gg a)).length + 1) + refine le_trans hseq_sp ?_ + set S := s a + (encOut (gg a)).length + 1 with hSdef + have hKS : K ≤ K * S := Nat.le_mul_of_pos_right K (by omega) + have hexp : (K + 2) * S = K * S + S + S := by rw [Nat.add_mul]; omega + have hrw : s a + ((encOut (gg a)).length + 1 + K) = S + K := by omega + omega + · -- the run halts + rw [hseq_run]; rfl + · -- output is the encoded result + rw [hseq_run] + simp only [Cfg.withState_output] + change (c₁.withState (some tmE.q₀)).output ++ encOut (gg a) = encOut (gg a) + rw [Cfg.withState_output, hc1def, wordsCfg_output, List.nil_append] + +/-- A `wordsCfg` over `k'` tapes, viewed as the `k`-tape `wordsCfg` on the tapes selected by `e`, +embedded with the remaining tapes carrying the leftover words. -/ +public lemma wordsCfg_eq_embed {k k' : ℕ} {State : Type} (e : Fin k ↪ Fin k') + (input : List Bool) (q : Option State) (ws : Fin k' → List Bool) (out : List Bool) : + wordsCfg input q ws out = + embed e (wordsCfg input q (fun j => ws (e j)) out) + (fun l => tapeOfList (ws l)) (fun _ => 0) := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + change tapeOfList (ws l) z = _ + rcases hpi : partialInv e l with _ | j + · simp [embed, hpi] + · simp only [embed, hpi, wordsCfg_workTapes, partialInv_eq_some e hpi] + · funext l + change (0 : ℤ) = _ + rcases hpi : partialInv e l with _ | j <;> simp [embed, hpi] +/-- **Reindexing preserves being a tape transformer.** If `M` transforms tapes along `P`/`Q`, then +`extendTapes M e` transforms them on the tapes selected by `e`, leaving the tapes outside the range +of `e` carried through unchanged (as the postcondition records), in the same time and space plus one +cell per added tape. -/ +public theorem transformsTapes_extendTapes {k k' : ℕ} {State : Type} + (e : Fin k ↪ Fin k') {M : MultiTapeTM k Bool State} + {P : (input : List Bool) → (Fin k → List Bool) → Prop} + {Q : (input : List Bool) → (Fin k → List Bool) → (Fin k → List Bool) → Prop} + {t s : ℕ} (h : TransformsTapes M P Q t s) : + TransformsTapes (extendTapes M e) + (fun input ws => P input (fun j => ws (e j))) + (fun input ws ws' => Q input (fun j => ws (e j)) (fun j => ws' (e j)) ∧ + ∀ l, (∀ j, e j ≠ l) → ws' l = ws l) + t (s + (k' - k)) := by + intro input ws out hP + -- the start config, viewed through the embedding + have hstart : wordsCfg input (some (extendTapes M e).q₀) ws out = + embed e (wordsCfg input (some M.q₀) (fun j => ws (e j)) out) + (fun l => tapeOfList (ws l)) (fun _ => 0) := + wordsCfg_eq_embed e input (some M.q₀) ws out + -- run the inner machine + obtain ⟨τ, hτ, ws', hrun, hQ, hsp⟩ := + h input (fun j => ws (e j)) out hP + refine ⟨τ, hτ, fun l => match partialInv e l with | some j => ws' j | none => ws l, ?_, ?_, ?_⟩ + · -- the run: the embedded halting config is a `wordsCfg` + rw [hstart, runFrom_embed, hrun] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + change (embed e (wordsCfg input (none : Option State) ws' out) + (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapes l z = + (wordsCfg input (none : Option State) + (fun l => match partialInv e l with | some j => ws' j | none => ws l) out).workTapes l z + rcases hpi : partialInv e l with _ | j + · simp [embed, hpi] + · simp [embed, hpi, wordsCfg_workTapes] + · funext l + change (embed e (wordsCfg input (none : Option State) ws' out) + (fun l => tapeOfList (ws l)) (fun _ => 0)).workTapePos l = (0 : ℤ) + rcases hpi : partialInv e l with _ | j <;> simp [embed, hpi] + · -- the postcondition + refine ⟨?_, ?_⟩ + · have : (fun j => (fun l => match partialInv e l with | some j => ws' j | none => ws l) (e j)) + = ws' := by + funext j; simp only [partialInv_embed] + rw [this]; exact hQ + · intro l hl + simp only [partialInv_eq_none e (fun ⟨j, hj⟩ => hl j hj)] + · -- the space + rw [hstart] + exact le_trans (spaceUsed_embed_le M e _ _ _ τ) (Nat.add_le_add_right hsp _) + +/-- Reading a `Function.update` back through an embedding: if the words on the tapes selected by `e` +form `Function.update … o₀ v` and every tape outside the range of `e` is unchanged, then the whole +vector is `Function.update … o v`, where `o = e o₀`. -/ +private lemma update_of_embed_update {K k : ℕ} (e : Fin K ↪ Fin k) + (o₀ : Fin K) (o : Fin k) (heo : e o₀ = o) + (ws ws' : Fin k → List Bool) (v : List Bool) + (hQ1 : (fun j => ws' (e j)) = Function.update (fun j => ws (e j)) o₀ v) + (hQ2 : ∀ l, (∀ j, e j ≠ l) → ws' l = ws l) : + ws' = Function.update ws o v := by + funext l + by_cases hlo : l = o + · subst hlo + have hh := congrFun hQ1 o₀ + simp only [heo, Function.update_self] at hh + rw [Function.update_self]; exact hh + · rw [Function.update_of_ne hlo] + by_cases hex : ∃ j, e j = l + · obtain ⟨j, rfl⟩ := hex + have hjo : j ≠ o₀ := by intro hj; apply hlo; rw [hj, heo] + have hh := congrFun hQ1 j + rw [Function.update_of_ne hjo] at hh + exact hh + · exact hQ2 l (fun j hj => hex ⟨j, hj⟩) + +/-- **Placement embedding (two pins).** Given distinct canonical indices `i₀ ≠ o₀` in `Fin K` and +distinct target indices `i ≠ o` in `Fin k` avoiding a set `keep`, with enough room +(`K + keep.card ≤ k`), there is an embedding `Fin K ↪ Fin k` sending `i₀ ↦ i`, `o₀ ↦ o`, and every +other index to a tape outside `insert i (insert o keep)`. -/ +private lemma exists_embed_placing {K k : ℕ} (i₀ o₀ : Fin K) (hio₀ : i₀ ≠ o₀) + (i o : Fin k) (keep : Finset (Fin k)) (hio : i ≠ o) (_hik : i ∉ keep) (_hok : o ∉ keep) + (hroom : K + keep.card ≤ k) : + ∃ e : Fin K ↪ Fin k, e i₀ = i ∧ e o₀ = o ∧ + ∀ j, j ≠ i₀ → j ≠ o₀ → e j ∉ insert i (insert o keep) := by + classical + set forb : Finset (Fin k) := insert i (insert o keep) with hforb + set avail : Finset (Fin k) := Finset.univ \ forb with havail + have hforb_card : forb.card ≤ keep.card + 2 := by + have h1 : (insert o keep).card ≤ keep.card + 1 := Finset.card_insert_le _ _ + have h2 : forb.card ≤ (insert o keep).card + 1 := by + rw [hforb]; exact Finset.card_insert_le _ _ + omega + have havail_card : avail.card = k - forb.card := by + rw [havail, Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, + Fintype.card_fin] + have hlhs : (Finset.univ \ {i₀, o₀} : Finset (Fin K)).card = K - 2 := by + rw [Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, Fintype.card_fin, + Finset.card_pair_eq_two_iff.mpr hio₀] + have hcard_le : Fintype.card {x : Fin K // x ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K))} + ≤ Fintype.card {x : Fin k // x ∈ avail} := by + simp only [Fintype.card_coe] + rw [hlhs, havail_card]; omega + obtain ⟨g⟩ := Function.Embedding.nonempty_of_card_le hcard_le + have hmem : ∀ j : Fin K, j ≠ i₀ → j ≠ o₀ → + j ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) := by + intro j hj1 hj2 + simp only [Finset.mem_sdiff, Finset.mem_univ, true_and, Finset.mem_insert, + Finset.mem_singleton, not_or] + exact ⟨hj1, hj2⟩ + have hg_forb : ∀ y : {x : Fin K // x ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K))}, + (g y).val ∉ forb := by + intro y + have hy : (g y).val ∈ Finset.univ \ forb := (g y).2 + exact (Finset.mem_sdiff.mp hy).2 + have hi_forb : i ∈ forb := by rw [hforb]; exact Finset.mem_insert_self _ _ + have ho_forb : o ∈ forb := by + rw [hforb]; exact Finset.mem_insert_of_mem (Finset.mem_insert_self _ _) + have hg_ne_i : ∀ y, (g y).val ≠ i := fun y hcon => hg_forb y (by rw [hcon]; exact hi_forb) + have hg_ne_o : ∀ y, (g y).val ≠ o := fun y hcon => hg_forb y (by rw [hcon]; exact ho_forb) + set f : Fin K → Fin k := fun j => + if hj : j ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) then (g ⟨j, hj⟩).val + else if j = i₀ then i else o with hf_def + have hmem_i₀ : i₀ ∉ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) := by simp + have hmem_o₀ : o₀ ∉ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) := by simp + have hfi₀ : f i₀ = i := by + rw [hf_def]; dsimp only; rw [dite_eq_right hmem_i₀]; exact ite_eq_left rfl + have hfo₀ : f o₀ = o := by + rw [hf_def]; dsimp only; rw [dite_eq_right hmem_o₀]; exact ite_eq_right (Ne.symm hio₀) + have hfother : ∀ j (hj : j ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K))), + f j = (g ⟨j, hj⟩).val := by + intro j hj; rw [hf_def]; dsimp only; rw [dite_eq_left hj] + have hf_inj : Function.Injective f := by + intro a b hab + by_cases ha : a ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) + · by_cases hb : b ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) + · rw [hfother a ha, hfother b hb] at hab + exact congrArg Subtype.val (g.injective (Subtype.ext hab)) + · exfalso + rw [hfother a ha] at hab + have hb' : b = i₀ ∨ b = o₀ := by + by_contra hbc; rw [not_or] at hbc; exact hb (hmem b hbc.1 hbc.2) + rcases hb' with rfl | rfl + · rw [hfi₀] at hab; exact hg_ne_i _ hab + · rw [hfo₀] at hab; exact hg_ne_o _ hab + · by_cases hb : b ∈ (Finset.univ \ {i₀, o₀} : Finset (Fin K)) + · exfalso + rw [hfother b hb] at hab + have ha' : a = i₀ ∨ a = o₀ := by + by_contra hac; rw [not_or] at hac; exact ha (hmem a hac.1 hac.2) + rcases ha' with rfl | rfl + · rw [hfi₀] at hab; exact hg_ne_i _ hab.symm + · rw [hfo₀] at hab; exact hg_ne_o _ hab.symm + · have ha' : a = i₀ ∨ a = o₀ := by + by_contra hac; rw [not_or] at hac; exact ha (hmem a hac.1 hac.2) + have hb' : b = i₀ ∨ b = o₀ := by + by_contra hbc; rw [not_or] at hbc; exact hb (hmem b hbc.1 hbc.2) + rcases ha' with rfl | rfl <;> rcases hb' with rfl | rfl + · rfl + · exfalso; rw [hfi₀, hfo₀] at hab; exact hio hab + · exfalso; rw [hfi₀, hfo₀] at hab; exact hio hab.symm + · rfl + refine ⟨⟨f, hf_inj⟩, hfi₀, hfo₀, ?_⟩ + intro j hj1 hj2 + change f j ∉ forb + rw [hfother j (hmem j hj1 hj2)] + exact hg_forb ⟨j, hmem j hj1 hj2⟩ + +/-- **Placement embedding (one pin).** Like `exists_embed_placing`, but pinning a single index +`o₀ ↦ o`, sending every other index outside `insert o keep`. -/ +private lemma exists_embed_placing_one {K k : ℕ} (o₀ : Fin K) + (o : Fin k) (keep : Finset (Fin k)) (_hok : o ∉ keep) (hroom : K + keep.card ≤ k) : + ∃ e : Fin K ↪ Fin k, e o₀ = o ∧ ∀ j, j ≠ o₀ → e j ∉ insert o keep := by + classical + set forb : Finset (Fin k) := insert o keep with hforb + set avail : Finset (Fin k) := Finset.univ \ forb with havail + have hforb_card : forb.card ≤ keep.card + 1 := by rw [hforb]; exact Finset.card_insert_le _ _ + have havail_card : avail.card = k - forb.card := by + rw [havail, Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, + Fintype.card_fin] + have hlhs : (Finset.univ \ {o₀} : Finset (Fin K)).card = K - 1 := by + rw [Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, Fintype.card_fin, + Finset.card_singleton] + have hcard_le : Fintype.card {x : Fin K // x ∈ (Finset.univ \ {o₀} : Finset (Fin K))} + ≤ Fintype.card {x : Fin k // x ∈ avail} := by + simp only [Fintype.card_coe] + rw [hlhs, havail_card]; omega + obtain ⟨g⟩ := Function.Embedding.nonempty_of_card_le hcard_le + have hmem : ∀ j : Fin K, j ≠ o₀ → j ∈ (Finset.univ \ {o₀} : Finset (Fin K)) := by + intro j hj + simp only [Finset.mem_sdiff, Finset.mem_univ, true_and, Finset.mem_singleton] + exact hj + have hg_forb : ∀ y : {x : Fin K // x ∈ (Finset.univ \ {o₀} : Finset (Fin K))}, + (g y).val ∉ forb := by + intro y + have hy : (g y).val ∈ Finset.univ \ forb := (g y).2 + exact (Finset.mem_sdiff.mp hy).2 + have ho_forb : o ∈ forb := by rw [hforb]; exact Finset.mem_insert_self _ _ + have hg_ne_o : ∀ y, (g y).val ≠ o := fun y hcon => hg_forb y (by rw [hcon]; exact ho_forb) + set f : Fin K → Fin k := fun j => + if hj : j ∈ (Finset.univ \ {o₀} : Finset (Fin K)) then (g ⟨j, hj⟩).val else o with hf_def + have hmem_o₀ : o₀ ∉ (Finset.univ \ {o₀} : Finset (Fin K)) := by simp + have hfo₀ : f o₀ = o := by rw [hf_def]; dsimp only; rw [dite_eq_right hmem_o₀] + have hfother : ∀ j (hj : j ∈ (Finset.univ \ {o₀} : Finset (Fin K))), + f j = (g ⟨j, hj⟩).val := by + intro j hj; rw [hf_def]; dsimp only; rw [dite_eq_left hj] + have hf_inj : Function.Injective f := by + intro a b hab + by_cases ha : a ∈ (Finset.univ \ {o₀} : Finset (Fin K)) + · by_cases hb : b ∈ (Finset.univ \ {o₀} : Finset (Fin K)) + · rw [hfother a ha, hfother b hb] at hab + exact congrArg Subtype.val (g.injective (Subtype.ext hab)) + · exfalso + rw [hfother a ha] at hab + have hb' : b = o₀ := by by_contra hbc; exact hb (hmem b hbc) + rw [hb', hfo₀] at hab; exact hg_ne_o _ hab + · by_cases hb : b ∈ (Finset.univ \ {o₀} : Finset (Fin K)) + · exfalso + rw [hfother b hb] at hab + have ha' : a = o₀ := by by_contra hac; exact ha (hmem a hac) + rw [ha', hfo₀] at hab; exact hg_ne_o _ hab.symm + · have ha' : a = o₀ := by by_contra hac; exact ha (hmem a hac) + have hb' : b = o₀ := by by_contra hbc; exact hb (hmem b hbc) + rw [ha', hb'] + refine ⟨⟨f, hf_inj⟩, hfo₀, ?_⟩ + intro j hj + change f j ∉ forb + rw [hfother j (hmem j hj)] + exact hg_forb ⟨j, hmem j hj⟩ + +/-- **A computable function, read from a work tape, as a tape transformer (general layout).** Placed +on any tape count `k` with a chosen input tape `i`, output tape `o` and a set `keep` of tapes to +leave untouched, provided there is room for the machine's own tapes. -/ +public theorem exists_transformsTapes_ofComputable {α β : Type*} {enc : α ↪ List Bool} + {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ m c : ℕ, ∀ (k : ℕ) (i o : Fin k) (keep : Finset (Fin k)), + i ≠ o → i ∉ keep → o ∉ keep → m + 2 + keep.card ≤ k → + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), ∀ a : α, + TransformsTapes tm + (fun _ ws => ws i = enc a ∧ ∀ l, l ≠ i → l ∉ keep → ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) + (c * (s a + (enc a).length + (encOut (g a)).length + 1) + k) := by + classical + obtain ⟨c, K, i₀, o₀, State₀, hfin₀, tm₀, hio₀, hcanon⟩ := + exists_transformsTapes_ofComputable_fixed h + have hK2 : 2 ≤ K := by + by_contra hlt + exact hio₀ (Fin.ext (by have := i₀.isLt; have := o₀.isLt; omega)) + refine ⟨K - 2, c, fun k i o keep hio hik hok hroom => ?_⟩ + have hKk : K ≤ k := by omega + have hroom' : K + keep.card ≤ k := by omega + obtain ⟨e, hei, heo, hother⟩ := + exists_embed_placing i₀ o₀ hio₀ i o keep hio hik hok hroom' + refine ⟨State₀, hfin₀, extendTapes tm₀ e, fun a => ?_⟩ + refine (transformsTapes_extendTapes e (hcanon a)).imp ?_ ?_ le_rfl ?_ + · -- precondition: the general layout satisfies the embedded canonical precondition + rintro input ws ⟨hwi, hwblank⟩ + refine ⟨?_, ?_⟩ + · change ws (e i₀) = enc a + rw [hei]; exact hwi + · intro l' hl' + change ws (e l') = [] + by_cases hlo : l' = o₀ + · subst hlo; rw [heo]; exact hwblank o (Ne.symm hio) hok + · have hmem := hother l' hl' hlo + rw [Finset.mem_insert, not_or] at hmem + obtain ⟨hne_i, hmem2⟩ := hmem + rw [Finset.mem_insert, not_or] at hmem2 + exact hwblank (e l') hne_i hmem2.2 + · -- postcondition: read the update back through the embedding + rintro input ws ws' _ ⟨hQ1, hQ2⟩ + exact update_of_embed_update e o₀ o heo ws ws' _ hQ1 hQ2 + · -- space + omega + +/-- **A computable function, read from the input tape, as a tape transformer (general layout).** +Placed on any tape count `k` with a chosen output tape `o` and a set `keep` of tapes to leave +untouched, provided there is room for the machine's own tapes. -/ +public theorem exists_transformsTapes_ofComputableInput {α β : Type*} {enc : α ↪ List Bool} + {encOut : β ↪ List Bool} {g : α → β} {t s : α → ℕ} + (h : ComputableInTimeAndSpace g enc encOut t s) : + ∃ m c : ℕ, ∀ (k : ℕ) (o : Fin k) (keep : Finset (Fin k)), + o ∉ keep → m + 1 + keep.card ≤ k → + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), ∀ a : α, + TransformsTapes tm + (fun input ws => input = enc a ∧ ∀ l, l ∉ keep → ws l = []) + (fun _ ws ws' => ws' = Function.update ws o (encOut (g a))) + (c * (t a + 1)) + (c * (s a + (encOut (g a)).length + 1) + k) := by + classical + obtain ⟨c, K, o₀, State₀, hfin₀, tm₀, hcanon⟩ := + exists_transformsTapes_ofComputableInput_fixed h + have hK1 : 1 ≤ K := by have := o₀.isLt; omega + refine ⟨K - 1, c, fun k o keep hok hroom => ?_⟩ + have hKk : K ≤ k := by omega + have hroom' : K + keep.card ≤ k := by omega + obtain ⟨e, heo, hother⟩ := exists_embed_placing_one o₀ o keep hok hroom' + refine ⟨State₀, hfin₀, extendTapes tm₀ e, fun a => ?_⟩ + refine (transformsTapes_extendTapes e (hcanon a)).imp ?_ ?_ le_rfl ?_ + · -- precondition + rintro input ws ⟨hinput, hwblank⟩ + refine ⟨hinput, ?_⟩ + intro l' + change ws (e l') = [] + by_cases hlo : l' = o₀ + · subst hlo; rw [heo]; exact hwblank o hok + · have hmem := hother l' hlo + rw [Finset.mem_insert, not_or] at hmem + exact hwblank (e l') hmem.2 + · -- postcondition + rintro input ws ws' _ ⟨hQ1, hQ2⟩ + exact update_of_embed_update e o₀ o heo ws ws' _ hQ1 hQ2 + · -- space + omega + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean new file mode 100644 index 0000000000..49a1ce0eb3 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Instrument.lean @@ -0,0 +1,369 @@ +/- +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 Mathlib.Algebra.BigOperators.Fin +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Instrumenting a machine with footprint tapes + +`instrument tm mark` runs `tm` unchanged while pairing each of its `k` work tapes with a +*footprint* tape: the footprint head moves in lockstep with its partner, and every cell it stands +on gets the symbol `mark` — unless the cell is already nonblank, which is what preserves a +distinguished anchor placed at cell `0` beforehand. A head path is connected, so the marked region +of a footprint is an interval: the footprint restores, next to a tape whose garbage may contain +embedded blanks, the scannability that the garbage lacks. This is the run phase of the tidy +normal form (`Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Tidy`); the sweep phase +erases each pair by walking the footprint towards the anchor. + +The instrumented machine relates to `tm` in two ways, and the split matters: + +* everything except the footprints is a *projection*: `projCfg` forgets the footprint tapes, and + `step` commutes with it unconditionally, so the instrumented run mirrors the original run by + `Turing.MultiTapeTM.runFrom_comm_of_step` — no induction; +* the footprint contents are a function of the run's *history*, not of its current configuration, + so they get their own run invariant: after `τ` live steps, footprint `j` carries `mark` exactly + on the cells its partner's head occupied before time `τ`, on top of what it held initially. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- `tm`, with each work tape `j` paired with the footprint tape `k + j`: the footprint head +mirrors the moves of head `j` and writes `mark` on every blank cell it stands on, leaving nonblank +cells (in particular an anchor at cell `0`) alone. -/ +@[expose] public def instrument (tm : MultiTapeTM k Symbol State) (mark : Symbol) : + MultiTapeTM (k + k) Symbol State where + q₀ := tm.q₀ + tr q inp work := + let a := tm.tr q inp fun j => work (j.castAdd k) + { inputTape := a.inputTape + workTapes := Fin.addCases (fun j => a.workTapes j) + (fun j => (match work (j.natAdd k) with + | none => some (some mark) + | some _ => none, (a.workTapes j).2)) + output := a.output + state := a.state } + +/-- Forgetting the footprint tapes of an instrumented configuration. -/ +@[expose, simps] public def projCfg (c : Cfg (k + k) Symbol State input) : + Cfg k Symbol State input := + ⟨c.state, c.inputPos, fun j => c.workTapes (j.castAdd k), fun j => c.workTapePos (j.castAdd k), + c.output⟩ + +@[simp] +public lemma projCfg_inputSymbol (c : Cfg (k + k) Symbol State input) : + (projCfg c).inputSymbol = c.inputSymbol := rfl + +@[simp] +public lemma projCfg_workTapeSymbols (c : Cfg (k + k) Symbol State input) (j : Fin k) : + (projCfg c).workTapeSymbols j = c.workTapeSymbols (j.castAdd k) := rfl + +/-- The projection is a step-semiconjugation: the instrumented machine acts on everything except +the footprints exactly as the original does. -/ +private lemma step_projCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg (k + k) Symbol State input) : + tm.step (projCfg c) = projCfg ((tm.instrument mark).step c) := by + cases hq : c.state with + | none => + have h1 : (projCfg c).state = none := hq + simp only [step, h1, hq] + | some q => + have h1 : (projCfg c).state = some q := hq + have hsym : (projCfg c).workTapeSymbols = fun j => c.workTapeSymbols (j.castAdd k) := rfl + simp only [step, h1, hq, projCfg_inputSymbol, hsym] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext j z + simp [Action.apply, instrument, Fin.addCases_left, projCfg] + · funext j + simp [Action.apply, instrument, Fin.addCases_left, projCfg] + +/-- The instrumented run mirrors the original run, footprints aside. -/ +public lemma runFrom_projCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg (k + k) Symbol State input) (n : ℕ) : + tm.runFrom (projCfg c) n = projCfg ((tm.instrument mark).runFrom c n) := + runFrom_comm_of_step projCfg (fun c => step_projCfg tm mark c) c n + +section Footprint + +variable {tm : MultiTapeTM k Symbol State} {mark : Symbol} + +/-- `Fin.addCases_right`, in the `addNat` spelling that `simp` normalises to. -/ +private lemma addCases_addNat {γ : Sort*} (f : Fin k → γ) (g : Fin k → γ) (j : Fin k) : + Fin.addCases (motive := fun _ => γ) f g (j.addNat k) = g j := by + rw [← Fin.natAdd_eq_addNat] + exact Fin.addCases_right j + +/-- The action of the instrumented machine moves a footprint head exactly as it moves the +partner head. -/ +private lemma instrument_move (q : State) (inp : Option Symbol) + (work : Fin (k + k) → Option Symbol) (j : Fin k) : + (((tm.instrument mark).tr q inp work).workTapes (j.addNat k)).2 = + (((tm.instrument mark).tr q inp work).workTapes (j.castAdd k)).2 := by + simp [instrument, Fin.addCases_left, addCases_addNat] + +/-- What the instrumented machine writes on a footprint: `mark` if the cell under the head is +blank, nothing otherwise. -/ +private lemma instrument_write (q : State) (inp : Option Symbol) + (work : Fin (k + k) → Option Symbol) (j : Fin k) : + (((tm.instrument mark).tr q inp work).workTapes (j.addNat k)).1 = + match work (j.addNat k) with + | none => some (some mark) + | some _ => none := by + simp [instrument, addCases_addNat] + +/-- A live step moves each head by the amount its action prescribes. -/ +private lemma step_workTapePos_of_state {C : Cfg (k + k) Symbol State input} {q : State} + (hq : C.state = some q) (l : Fin (k + k)) : + ((tm.instrument mark).step C).workTapePos l = + C.workTapePos l + + (((tm.instrument mark).tr q C.inputSymbol C.workTapeSymbols).workTapes l).2 := by + simp [step, hq, Action.apply] + +/-- Footprint heads stay aligned with their partners throughout a live run. -/ +public lemma workTapePos_addNat_instrument (c : Cfg (k + k) Symbol State input) (j : Fin k) + (halign : c.workTapePos (j.addNat k) = c.workTapePos (j.castAdd k)) (τ : ℕ) + (hlive : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none) : + ((tm.instrument mark).runFrom c τ).workTapePos (j.addNat k) = + ((tm.instrument mark).runFrom c τ).workTapePos (j.castAdd k) := by + induction τ with + | zero => exact halign + | succ τ ih => + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp (hlive τ (by omega)) + rw [runFrom_succ_eq_step', step_workTapePos_of_state hq, step_workTapePos_of_state hq, + instrument_move, ih fun m hm => hlive m (by omega)] + +/-- **The footprint invariant.** After `τ` live steps, footprint `j` holds `mark` on every cell +its partner's head occupied at an earlier time, on top of what it held initially — which is never +overwritten, so an anchor placed before the run survives it. -/ +public lemma workTapes_addNat_instrument (c : Cfg (k + k) Symbol State input) (j : Fin k) + (halign : c.workTapePos (j.addNat k) = c.workTapePos (j.castAdd k)) (τ : ℕ) + (hlive : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none) : + ((tm.instrument mark).runFrom c τ).workTapes (j.addNat k) = fun z => + match c.workTapes (j.addNat k) z with + | some s => some s + | none => + if z ∈ (Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) then + some mark + else none := by + induction τ with + | zero => + funext z + rcases h : c.workTapes (j.addNat k) z with _ | s <;> simp [h] + | succ τ ih => + have hlive' : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none := + fun m hm => hlive m (by omega) + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp (hlive τ (by omega)) + set Cτ := (tm.instrument mark).runFrom c τ with hCτ + -- the footprint head stands on the partner's position + have hpos : Cτ.workTapePos (j.addNat k) = Cτ.workTapePos (j.castAdd k) := + workTapePos_addNat_instrument c j halign τ hlive' + have hstep : ((tm.instrument mark).runFrom c (τ + 1)).workTapes (j.addNat k) = + match (((tm.instrument mark).tr q Cτ.inputSymbol Cτ.workTapeSymbols).workTapes + (j.addNat k)).1 with + | none => Cτ.workTapes (j.addNat k) + | some s => + Function.update (Cτ.workTapes (j.addNat k)) (Cτ.workTapePos (j.addNat k)) s := by + rw [runFrom_succ_eq_step', ← hCτ] + simp only [step, hq, Action.apply] + rfl + rw [hstep, instrument_write] + have hmarks : (Finset.range (τ + 1)).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) = + insert (Cτ.workTapePos (j.castAdd k)) ((Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k))) := by + rw [Finset.range_add_one, Finset.image_insert, hCτ] + -- the current footprint cell, read through the invariant at time `τ` + have hread : Cτ.workTapeSymbols (j.addNat k) = + match c.workTapes (j.addNat k) (Cτ.workTapePos (j.castAdd k)) with + | some s => some s + | none => + if Cτ.workTapePos (j.castAdd k) ∈ (Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) then + some mark + else none := by + simp only [Cfg.workTapeSymbols, hpos, ih hlive'] + rw [hread] + funext z + rcases hinit : c.workTapes (j.addNat k) (Cτ.workTapePos (j.castAdd k)) with _ | s + · -- the cell under the head was initially blank + by_cases hmem : Cτ.workTapePos (j.castAdd k) ∈ (Finset.range τ).image + (fun m => ((tm.instrument mark).runFrom c m).workTapePos (j.castAdd k)) + · -- already marked: nothing written, and the new mark set adds nothing at this cell + simp only [hmem, ite_true] + rw [ih hlive', hmarks] + rcases hz : c.workTapes (j.addNat k) z with _ | s + · simp only [hz, Finset.mem_insert] + by_cases hzp : z = Cτ.workTapePos (j.castAdd k) + · subst hzp; simp [hmem] + · simp [hzp] + · simp [hz] + · -- unmarked: the machine writes `mark` at the head position + simp only [hmem, ite_false] + rw [hpos, ih hlive', hmarks] + by_cases hzp : z = Cτ.workTapePos (j.castAdd k) + · subst hzp + simp [Function.update_self, hinit] + · rw [Function.update_of_ne hzp] + rcases hz : c.workTapes (j.addNat k) z with _ | s + · simp [hzp] + · simp + · -- the cell under the head was initially nonblank: nothing written + rw [ih hlive', hmarks] + rcases hz : c.workTapes (j.addNat k) z with _ | s + · simp only [hz, Finset.mem_insert] + by_cases hzp : z = Cτ.workTapePos (j.castAdd k) + · subst hzp; simp_all + · simp [hzp] + · simp [hz] + +end Footprint + +section MarkAnchors + +/-- The one-step machine that writes `mark` on every footprint tape at its head — placing the +anchors before an instrumented run — and halts. Everything else is untouched. -/ +private def markAnchors (k : ℕ) (Symbol : Type*) (mark : Symbol) : + MultiTapeTM (k + k) Symbol Unit where + q₀ := () + tr _ _ _ := + { inputTape := 0 + workTapes := Fin.addCases (fun _ => (none, 0)) (fun _ => (some (some mark), 0)) + output := none + state := none } + +/-- One step of `markAnchors`: anchors written at the footprint heads, nothing else changed. -/ +public theorem exists_markAnchors (k : ℕ) (Symbol : Type*) (mark : Symbol) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM (k + k) Symbol State), + ∀ (input : List Symbol) (c : Cfg (k + k) Symbol State input), c.state = some tm.q₀ → + (tm.runFrom c 1).state = none ∧ + (tm.runFrom c 1).inputPos = c.inputPos ∧ + (tm.runFrom c 1).output = c.output ∧ + (tm.runFrom c 1).workTapePos = c.workTapePos ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.castAdd k) = c.workTapes (j.castAdd k)) ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.addNat k) = + Function.update (c.workTapes (j.addNat k)) (c.workTapePos (j.addNat k)) (some mark)) := by + refine ⟨Unit, inferInstance, markAnchors k Symbol mark, fun input c hq => ?_⟩ + have hstep : (markAnchors k Symbol mark).runFrom c 1 = (markAnchors k Symbol mark).step c := by + rw [runFrom_succ_eq_step', runFrom_zero] + rw [hstep] + refine ⟨?_, ?_, ?_, ?_, fun j => ?_, fun j => ?_⟩ + · simp [step, hq, Action.apply, markAnchors] + · simp [step, hq, Action.apply, markAnchors] + · simp [step, hq, Action.apply, markAnchors] + · funext l + induction l using Fin.addCases with + | left j => simp [step, hq, Action.apply, markAnchors, Fin.addCases_left] + | right j => simp [step, hq, Action.apply, markAnchors, addCases_addNat] + · simp [step, hq, Action.apply, markAnchors, Fin.addCases_left] + · simp [step, hq, Action.apply, markAnchors, addCases_addNat] + +/-- The one-step machine that writes `mark` on every footprint tape at its head — but only on a +blank cell, so an anchor under a head survives. Run after an instrumented machine halts, it marks +the final head positions, which the run itself never wrote: the footprint then covers exactly the +visited cells. -/ +private def markCurrent (k : ℕ) (Symbol : Type*) (mark : Symbol) : + MultiTapeTM (k + k) Symbol Unit where + q₀ := () + tr _ _ work := + { inputTape := 0 + workTapes := Fin.addCases (fun _ => (none, 0)) + (fun j => (match work (j.natAdd k) with + | none => some (some mark) + | some _ => none, 0)) + output := none + state := none } + +/-- One step of `markCurrent`: the cells under the footprint heads are marked if blank, nothing +else changes. -/ +public theorem exists_markCurrent (k : ℕ) (Symbol : Type*) (mark : Symbol) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM (k + k) Symbol State), + ∀ (input : List Symbol) (c : Cfg (k + k) Symbol State input), c.state = some tm.q₀ → + (tm.runFrom c 1).state = none ∧ + (tm.runFrom c 1).inputPos = c.inputPos ∧ + (tm.runFrom c 1).output = c.output ∧ + (tm.runFrom c 1).workTapePos = c.workTapePos ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.castAdd k) = c.workTapes (j.castAdd k)) ∧ + (∀ j : Fin k, (tm.runFrom c 1).workTapes (j.addNat k) = fun z => + match c.workTapes (j.addNat k) z with + | some s => some s + | none => + if z = c.workTapePos (j.addNat k) ∧ + c.workTapes (j.addNat k) (c.workTapePos (j.addNat k)) = none then + some mark + else none) := by + refine ⟨Unit, inferInstance, markCurrent k Symbol mark, fun input c hq => ?_⟩ + have hstep : (markCurrent k Symbol mark).runFrom c 1 = (markCurrent k Symbol mark).step c := by + rw [runFrom_succ_eq_step', runFrom_zero] + rw [hstep] + refine ⟨?_, ?_, ?_, ?_, fun j => ?_, fun j => ?_⟩ + · simp [step, hq, Action.apply, markCurrent] + · simp [step, hq, Action.apply, markCurrent] + · simp [step, hq, Action.apply, markCurrent] + · funext l + induction l using Fin.addCases with + | left j => simp [step, hq, Action.apply, markCurrent, Fin.addCases_left] + | right j => + rcases h : c.workTapeSymbols (j.natAdd k) with _ | s <;> + simp [step, hq, Action.apply, markCurrent, addCases_addNat] + · simp [step, hq, Action.apply, markCurrent, Fin.addCases_left] + · funext z + simp only [step, hq, Action.apply, markCurrent, addCases_addNat] + rw [show c.workTapeSymbols (Fin.natAdd k j) = + c.workTapes (j.addNat k) (c.workTapePos (j.addNat k)) from by + rw [Fin.natAdd_eq_addNat]; rfl] + rcases hcell : c.workTapes (j.addNat k) (c.workTapePos (j.addNat k)) with _ | s + · -- blank under the head: write the mark there + by_cases hz : z = c.workTapePos (j.addNat k) + · subst hz + simp [hcell, Function.update_self] + · rcases hzc : c.workTapes (j.addNat k) z with _ | t <;> + simp [hzc, hz] + · -- nonblank under the head: no write + rcases hzc : c.workTapes (j.addNat k) z with _ | t <;> simp [hzc] + +end MarkAnchors + +section Space + +/-- An instrumented run uses exactly twice the space of the original: each footprint head visits +exactly the cells its partner visits. -/ +public lemma spaceUsed_instrument (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg (k + k) Symbol State input) (τ : ℕ) + (halign : ∀ j : Fin k, c.workTapePos (j.addNat k) = c.workTapePos (j.castAdd k)) + (hlive : ∀ m < τ, ((tm.instrument mark).runFrom c m).state ≠ none) : + (tm.instrument mark).spaceUsed c τ = 2 * tm.spaceUsed (projCfg c) τ := by + have hcast : ∀ (j : Fin k), + (tm.instrument mark).visitedByTapeHead c τ (j.castAdd k) = + tm.visitedByTapeHead (projCfg c) τ j := by + intro j + refine Finset.image_congr fun m hm => ?_ + rw [runFrom_projCfg tm mark] + rfl + have hnat : ∀ (j : Fin k), + (tm.instrument mark).visitedByTapeHead c τ (j.addNat k) = + tm.visitedByTapeHead (projCfg c) τ j := by + intro j + refine Finset.image_congr fun m hm => ?_ + have hm' : m ≤ τ := Nat.lt_succ_iff.mp (Finset.mem_range.mp hm) + rw [workTapePos_addNat_instrument c j (halign j) m fun r hr => hlive r (by omega), + runFrom_projCfg tm mark] + rfl + rw [spaceUsed, spaceUsed, Fin.sum_univ_add, two_mul] + congr 1 + · exact Finset.sum_congr rfl fun j _ => congrArg Finset.card (hcast j) + · refine Finset.sum_congr rfl fun j _ => congrArg Finset.card ?_ + -- natAdd vs addNat spelling + rw [Fin.natAdd_eq_addNat] + exact hnat j +end Space + + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean new file mode 100644 index 0000000000..ffb496797e --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Sweep.lean @@ -0,0 +1,670 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Sweeping a footprinted tape pair clean + +The machine of this file erases one work tape whose garbage may contain embedded blanks — so no +scan of the tape itself can find its extent — guided by the *footprint* tape produced by +`Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument`: a contiguous block of +marks over the visited interval, with a distinguished anchor at cell `0`. + +The protocol erases outside-in towards the anchor and consumes it last, which is what lets both +heads end at cell `0` with everything blank, without any counting: + +1. `goRight`: walk right over the marks to the right end of the footprint; +2. `toAnchor`: sweep left, erasing garbage and marks, until the anchor — which is kept, while the + garbage under it is erased; +3. `sweepLeft`: continue sweeping left over the remaining marks to the left end; +4. `seek`: walk right over the now-blank cells; the first nonblank cell is the anchor, i.e. + cell `0`: erase it and halt. + +Both heads move in lockstep throughout, so they home together, and the excursion never leaves the +footprint interval widened by one cell on each side — which is what bounds the sweep's space by +the instrumented run's own. +-/ + +namespace Turing.MultiTapeTM + +namespace Sweep + +/-- The four phases of the sweep. -/ +private inductive SweepState | goRight | toAnchor | sweepLeft | seek +deriving DecidableEq + +private instance : Finite SweepState := + Finite.of_injective + (fun s => match s with + | .goRight => (0 : Fin 4) | .toAnchor => 1 | .sweepLeft => 2 | .seek => 3) + (fun a b h => by cases a <;> cases b <;> simp_all) + +variable {K : ℕ} (i fp : Fin K) + +/-- An action of the sweep: optional writes on the pair, the same move for both heads, everything +else untouched. -/ +private def act (wi wf : Option (Option Bool)) (m : SignType) (q : Option SweepState) : + Action K Bool SweepState where + inputTape := 0 + workTapes l := if l = i then (wi, m) else if l = fp then (wf, m) else (none, 0) + output := none + state := q + +/-- The sweep machine. It reads only the footprint tape. -/ +private def sweep : MultiTapeTM K Bool SweepState where + q₀ := .goRight + tr q _ work := + match q, work fp with + | .goRight, some _ => act i fp none none 1 (some .goRight) + | .goRight, none => act i fp none none (-1) (some .toAnchor) + | .toAnchor, some false => act i fp (some none) (some none) (-1) (some .toAnchor) + | .toAnchor, some true => act i fp (some none) none (-1) (some .sweepLeft) + | .toAnchor, none => act i fp none none 0 none + | .sweepLeft, some _ => act i fp (some none) (some none) (-1) (some .sweepLeft) + | .sweepLeft, none => act i fp none none 1 (some .seek) + | .seek, none => act i fp none none 1 (some .seek) + | .seek, some _ => act i fp none (some none) 0 none + +variable {input : List Bool} + +/-- The configurations the sweep passes through: both heads at `p`, the pair holding `Ti` and +`Tf`, everything else frozen from `base`. -/ +private def cfg (base : Cfg K Bool SweepState input) (q : Option SweepState) (p : ℤ) + (Ti Tf : ℤ → Option Bool) : Cfg K Bool SweepState input := + ⟨q, base.inputPos, + Function.update (Function.update base.workTapes i Ti) fp Tf, + Function.update (Function.update base.workTapePos i p) fp p, + base.output⟩ + +variable {i fp} (hifp : i ≠ fp) + +private lemma cfg_workTapes_fp (base : Cfg K Bool SweepState input) (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapes fp = Tf := by + simp [cfg] + +private lemma cfg_workTapePos_fp (base : Cfg K Bool SweepState input) (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapePos fp = p := by + simp [cfg] + +/-- The effect of an optional write at position `p`. -/ +private def applyWrite (T : ℤ → Option Bool) (p : ℤ) : Option (Option Bool) → ℤ → Option Bool + | none => T + | some s => Function.update T p s + +@[simp] private lemma applyWrite_none (T : ℤ → Option Bool) (p : ℤ) : + applyWrite T p none = T := rfl + +@[simp] private lemma applyWrite_some (T : ℤ → Option Bool) (p : ℤ) (s : Option Bool) : + applyWrite T p (some s) = Function.update T p s := rfl + +include hifp in +/-- One step of the sweep from a sweep configuration, given what the transition does. -/ +private lemma step_cfg (base : Cfg K Bool SweepState input) (q : SweepState) (p : ℤ) + (Ti Tf : ℤ → Option Bool) (wi wf : Option (Option Bool)) (m : SignType) + (q' : Option SweepState) + (htr : ∀ inp work, work fp = Tf p → + (sweep i fp).tr q inp work = act i fp wi wf m q') : + (sweep i fp).step (cfg i fp base (some q) p Ti Tf) = + cfg i fp base q' (p + m) (applyWrite Ti p wi) (applyWrite Tf p wf) := by + have hq : (cfg i fp base (some q) p Ti Tf).state = some q := rfl + have hwork : (cfg i fp base (some q) p Ti Tf).workTapeSymbols fp = Tf p := by + simp [Cfg.workTapeSymbols, cfg_workTapes_fp, cfg_workTapePos_fp] + simp only [step, hq] + rw [htr _ _ hwork] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp [Action.apply, act, cfg] + · funext l z + by_cases hl : l = fp + · subst hl + rcases wf with _ | s <;> + simp [Action.apply, act, cfg, Ne.symm hifp, applyWrite] + · by_cases hli : l = i + · subst hli + rcases wi with _ | s <;> + simp [Action.apply, act, cfg, hifp, applyWrite] + · simp [Action.apply, act, cfg, hl, hli] + · funext l + by_cases hl : l = fp + · subst hl + simp [Action.apply, act, cfg, Ne.symm hifp] + · by_cases hli : l = i + · subst hli + simp [Action.apply, act, cfg, hifp] + · simp [Action.apply, act, cfg, hl, hli] + · simp [Action.apply, act, cfg] + +section Run + +variable (l r : ℤ) + +/-- The footprint over the interval `[l, r]`: the anchor at `0`, marks elsewhere. -/ +private def F : ℤ → Option Bool := fun z => + if z = 0 then some true else if l ≤ z ∧ z ≤ r then some false else none + +/-- A tape erased strictly above `q`. -/ +private def eraseAbove (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => + if q < z then none else T z + +/-- The footprint after the left sweep has reached position `q`: everything at `q + 1` and above +erased except the anchor. -/ +private def eraseKeepAnchor (T : ℤ → Option Bool) (q : ℤ) : ℤ → Option Bool := fun z => + if q < z ∧ z ≠ 0 then none else T z + +variable (base : Cfg K Bool SweepState input) (G : ℤ → Option Bool) + +private lemma cast_one : ((1 : SignType) : ℤ) = 1 := rfl +private lemma cast_neg_one : ((-1 : SignType) : ℤ) = -1 := rfl +private lemma cast_zero : ((0 : SignType) : ℤ) = 0 := rfl + +include hifp in +/-- Phase 1: walk right over the marks. -/ +private lemma run_goRight (p : ℤ) (hlp : l ≤ p) (d : ℕ) (hd : p + d ≤ r + 1) : + (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) d = + cfg i fp base (some .goRight) (p + d) G (F l r) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hbound : l ≤ p + (d : ℤ) ∧ p + (d : ℤ) ≤ r := by omega + have hread : F l r (p + d) ≠ none := by + simp only [F] + by_cases h0 : p + (d : ℤ) = 0 <;> simp [h0, hbound] + obtain ⟨b, hb⟩ := Option.ne_none_iff_exists'.mp hread + rw [step_cfg hifp base .goRight (p + d) G (F l r) none none 1 (some .goRight) + (fun inp work hw => by simp only [sweep]; rw [hw, hb])] + rw [show p + (d : ℤ) + ((1 : SignType) : ℤ) = p + ((d + 1 : ℕ) : ℤ) from by + rw [cast_one]; omega] + simp + +include hifp in +/-- The turn at the right end of the footprint. -/ +private lemma step_turn (_hl0 : l ≤ 0) (hr : 0 ≤ r) : + (sweep i fp).step (cfg i fp base (some .goRight) (r + 1) G (F l r)) = + cfg i fp base (some .toAnchor) r G (F l r) := by + have hread : F l r (r + 1) = none := by + have h1 : ¬ (r + 1 = 0) := by omega + have h2 : ¬ (l ≤ r + 1 ∧ r + 1 ≤ r) := by omega + simp [F, h1] + rw [step_cfg hifp base .goRight (r + 1) G (F l r) none none (-1) (some .toAnchor) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show r + 1 + ((-1 : SignType) : ℤ) = r from by rw [cast_neg_one]; omega] + simp + +/-- Blanking the boundary cell of an erased-above tape pushes the boundary down. -/ +private lemma update_eraseAbove (T : ℤ → Option Bool) (q : ℤ) : + Function.update (eraseAbove T q) q none = eraseAbove T (q - 1) := by + funext z + by_cases hz : z = q + · subst hz; simp [eraseAbove] + · rw [Function.update_of_ne hz] + have h : q - 1 < z ↔ q < z := by omega + simp [eraseAbove, h] + +/-- The same, one side of the anchor. -/ +private lemma update_eraseKeepAnchor (T : ℤ → Option Bool) (q : ℤ) (hq : q ≠ 0) : + Function.update (eraseKeepAnchor T q) q none = eraseKeepAnchor T (q - 1) := by + funext z + by_cases hz : z = q + · subst hz; simp [eraseKeepAnchor, hq] + · rw [Function.update_of_ne hz] + have h : (q - 1 < z ∧ z ≠ 0) ↔ (q < z ∧ z ≠ 0) ∨ z = q ∧ z ≠ 0 := by omega + by_cases h0 : z = 0 + · simp [eraseKeepAnchor, h0] + · simp only [eraseKeepAnchor, h0, and_true, ne_eq, not_false_iff] + have : (q - 1 < z) ↔ (q < z) := by omega + simp [this] + +/-- After erasing down to the anchor, the footprint is the anchor-keeping erasure from `-1`. -/ +private lemma eraseAbove_zero_eq (T : ℤ → Option Bool) : + eraseAbove T 0 = eraseKeepAnchor T (-1) := by + funext z + rcases lt_trichotomy z 0 with h | h | h + · have h1 : ¬ (0 < z) := by omega + have h2 : ¬ (-1 < z ∧ z ≠ 0) := by omega + simp [eraseAbove, eraseKeepAnchor, h1, h2] + · subst h + simp [eraseAbove, eraseKeepAnchor] + · have h1 : 0 < z := h + have h2 : -1 < z ∧ z ≠ 0 := by omega + simp [eraseAbove, eraseKeepAnchor, h1, h2] + +include hifp in +/-- Phase 2: sweep left from the right end down to the anchor, erasing both tapes. -/ +private lemma run_toAnchor (hl0 : l ≤ 0) (_h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ r) : + (sweep i fp).runFrom + (cfg i fp base (some .toAnchor) r (eraseAbove G r) (eraseAbove (F l r) r)) d = + cfg i fp base (some .toAnchor) (r - d) (eraseAbove G (r - d)) + (eraseAbove (F l r) (r - d)) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hq : (1 : ℤ) ≤ r - d := by omega + have hread : eraseAbove (F l r) (r - d) (r - d) = some false := by + have h0 : ¬ (r - (d : ℤ) = 0) := by omega + have hin : l ≤ r - (d : ℤ) ∧ r - (d : ℤ) ≤ r := by omega + simp [eraseAbove, F, h0, hin] + rw [step_cfg hifp base .toAnchor (r - d) (eraseAbove G (r - d)) (eraseAbove (F l r) (r - d)) + (some none) (some none) (-1) (some .toAnchor) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show r - (d : ℤ) + ((-1 : SignType) : ℤ) = r - ((d + 1 : ℕ) : ℤ) from by + rw [cast_neg_one]; omega] + rw [applyWrite_some, applyWrite_some, update_eraseAbove, update_eraseAbove, + show r - (d : ℤ) - 1 = r - ((d + 1 : ℕ) : ℤ) from by omega] + +include hifp in +/-- The anchor step: erase the garbage under the anchor, keep the anchor, turn left. -/ +private lemma step_anchor (_hl0 : l ≤ 0) (_h0r : 0 ≤ r) : + (sweep i fp).step + (cfg i fp base (some .toAnchor) 0 (eraseAbove G 0) (eraseAbove (F l r) 0)) = + cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) + (eraseKeepAnchor (F l r) (-1)) := by + have hread : eraseAbove (F l r) 0 0 = some true := by simp [eraseAbove, F] + rw [step_cfg hifp base .toAnchor 0 (eraseAbove G 0) (eraseAbove (F l r) 0) + (some none) none (-1) (some .sweepLeft) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show (0 : ℤ) + ((-1 : SignType) : ℤ) = -1 from by rw [cast_neg_one]; omega] + rw [applyWrite_some, applyWrite_none, + show Function.update (eraseAbove G 0) 0 none = eraseAbove G (-1) from by + have h := update_eraseAbove G 0 + simpa using h, + eraseAbove_zero_eq (F l r)] + +include hifp in +/-- Phase 3: sweep left below the anchor, erasing both tapes. -/ +private lemma run_sweepLeft (_hl0 : l ≤ 0) (h0r : 0 ≤ r) (d : ℕ) (hd : (d : ℤ) ≤ -l) : + (sweep i fp).runFrom + (cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) + (eraseKeepAnchor (F l r) (-1))) d = + cfg i fp base (some .sweepLeft) (-1 - d) (eraseAbove G (-1 - d)) + (eraseKeepAnchor (F l r) (-1 - d)) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hq : l ≤ -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≤ -1 := by omega + have hread : eraseKeepAnchor (F l r) (-1 - d) (-1 - d) = some false := by + have h0 : ¬ (-1 - (d : ℤ) = 0) := by omega + have hc : ¬ (-1 - (d : ℤ) < -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≠ 0) := by omega + have hin : l ≤ -1 - (d : ℤ) ∧ -1 - (d : ℤ) ≤ r := by omega + simp [eraseKeepAnchor, F, h0, hin] + rw [step_cfg hifp base .sweepLeft (-1 - d) (eraseAbove G (-1 - d)) + (eraseKeepAnchor (F l r) (-1 - d)) (some none) (some none) (-1) (some .sweepLeft) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show (-1 : ℤ) - (d : ℤ) + ((-1 : SignType) : ℤ) = -1 - ((d + 1 : ℕ) : ℤ) from by + rw [cast_neg_one]; omega] + rw [applyWrite_some, applyWrite_some, update_eraseAbove, + update_eraseKeepAnchor (F l r) _ (by omega), + show (-1 : ℤ) - (d : ℤ) - 1 = -1 - ((d + 1 : ℕ) : ℤ) from by omega] + +include hifp in +/-- The turn at the left end of the footprint. -/ +private lemma step_turnLeft (hl0 : l ≤ 0) : + (sweep i fp).step + (cfg i fp base (some .sweepLeft) (l - 1) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1))) = + cfg i fp base (some .seek) l (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1)) := by + have hread : eraseKeepAnchor (F l r) (l - 1) (l - 1) = none := by + have hc : ¬ (l - 1 < l - 1 ∧ l - 1 ≠ 0) := by omega + have h0 : ¬ (l - 1 = 0) := by omega + have hin : ¬ (l ≤ l - 1 ∧ l - 1 ≤ r) := by omega + simp [eraseKeepAnchor, F, h0] + rw [step_cfg hifp base .sweepLeft (l - 1) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) none none 1 (some .seek) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show l - 1 + ((1 : SignType) : ℤ) = l from by rw [cast_one]; omega] + simp + +include hifp in +/-- Phase 4: walk right over the erased cells towards the anchor. -/ +private lemma run_seek (_hl0 : l ≤ 0) (d : ℕ) (hd : (d : ℤ) ≤ -l) : + (sweep i fp).runFrom + (cfg i fp base (some .seek) l (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1))) d = + cfg i fp base (some .seek) (l + d) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', ih (by omega)] + have hread : eraseKeepAnchor (F l r) (l - 1) (l + d) = none := by + have hc : l - 1 < l + (d : ℤ) ∧ l + (d : ℤ) ≠ 0 := by omega + simp [eraseKeepAnchor, hc] + rw [step_cfg hifp base .seek (l + d) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) none none 1 (some .seek) + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show l + (d : ℤ) + ((1 : SignType) : ℤ) = l + ((d + 1 : ℕ) : ℤ) from by + rw [cast_one]; omega] + simp + +include hifp in +/-- The halting step: erase the anchor, stay at `0`. -/ +private lemma step_final (_hl0 : l ≤ 0) : + (sweep i fp).step + (cfg i fp base (some .seek) 0 (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1))) = + cfg i fp base none 0 (eraseAbove G (l - 1)) + (Function.update (eraseKeepAnchor (F l r) (l - 1)) 0 none) := by + have hread : eraseKeepAnchor (F l r) (l - 1) 0 = some true := by + have hc : ¬ (l - 1 < (0 : ℤ) ∧ (0 : ℤ) ≠ 0) := by omega + simp [eraseKeepAnchor, F] + rw [step_cfg hifp base .seek 0 (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) none (some none) 0 none + (fun inp work hw => by simp only [sweep]; rw [hw, hread])] + rw [show (0 : ℤ) + ((0 : SignType) : ℤ) = 0 from by rw [cast_zero]; omega] + simp + +/-- After the sweep, the garbage tape is blank. -/ +private lemma eraseAbove_final (hG : ∀ z, z < l ∨ r < z → G z = none) : + eraseAbove G (l - 1) = fun _ => none := by + funext z + by_cases h : l - 1 < z + · simp [eraseAbove, h] + · simp [eraseAbove, h, hG z (Or.inl (by omega))] + +/-- After the sweep, the footprint is blank. -/ +private lemma eraseKeepAnchor_final (_hl0 : l ≤ 0) : + Function.update (eraseKeepAnchor (F l r) (l - 1)) 0 none = fun _ => none := by + funext z + by_cases h0 : z = 0 + · subst h0; simp + · rw [Function.update_of_ne h0] + by_cases h : l - 1 < z + · simp [eraseKeepAnchor, h, h0] + · have hF : F l r z = none := by + have hin : ¬ (l ≤ z ∧ z ≤ r) := by omega + simp [F, h0, hin] + simp [eraseKeepAnchor, hF] + +/-- The number of steps of the full sweep, started at position `p`. -/ +private def steps (l r p : ℤ) : ℕ := + (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat + 1 + +include hifp in +/-- The garbage tape is blank above `r` and the footprint is exactly `F`: the sweep erases +everything and homes both heads. -/ +private lemma run_full (hl0 : l ≤ 0) (h0r : 0 ≤ r) (p : ℤ) (hlp : l ≤ p) (hpr : p ≤ r) + (hG : ∀ z, z < l ∨ r < z → G z = none) : + (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) (steps l r p) = + cfg i fp base none 0 (fun _ => none) (fun _ => none) := by + have hGr : eraseAbove G r = G := by + funext z + by_cases h : r < z + · simp [eraseAbove, h, hG z (Or.inr h)] + · simp [eraseAbove, h] + have hFr : eraseAbove (F l r) r = F l r := by + funext z + by_cases h : r < z + · have h0 : ¬ (z = 0) := by omega + have hin : ¬ (l ≤ z ∧ z ≤ r) := by omega + simp [eraseAbove, F, h, h0, hin] + · simp [eraseAbove, h] + -- segment 1: to the right end + have e₁ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat) = cfg i fp base (some .goRight) (r + 1) G (F l r) := by + rw [run_goRight hifp l r base G p hlp ((r + 1 - p).toNat) (by omega), + show p + ((r + 1 - p).toNat : ℤ) = r + 1 from by omega] + -- segment 2: turn, then down to the anchor + have e₂ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat) = + cfg i fp base (some .toAnchor) 0 (eraseAbove G 0) (eraseAbove (F l r) 0) := by + rw [runFrom_add, runFrom_add, e₁, runFrom_succ_eq_step', runFrom_zero, + step_turn hifp l r base G hl0 h0r] + have h := run_toAnchor hifp l r base G hl0 h0r r.toNat (by omega) + rw [hGr, hFr, show r - (r.toNat : ℤ) = 0 from by omega] at h + exact h + -- segment 3: the anchor step, then down to the left end + have e₃ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat) = + cfg i fp base (some .sweepLeft) (l - 1) (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, runFrom_add, e₂, runFrom_succ_eq_step', runFrom_zero, + step_anchor hifp l r base G hl0 h0r, + run_sweepLeft hifp l r base G hl0 h0r (-l).toNat (by omega), + show (-1 : ℤ) - ((-l).toNat : ℤ) = l - 1 from by omega] + -- segment 4: turn at the left end + have e₄ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1) = + cfg i fp base (some .seek) l (eraseAbove G (l - 1)) (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, e₃, runFrom_succ_eq_step', runFrom_zero, + step_turnLeft hifp l r base G hl0] + -- segment 5: up to the anchor + have e₅ : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat) = + cfg i fp base (some .seek) 0 (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, e₄] + have h := run_seek hifp l r base G hl0 (-l).toNat (by omega) + rw [show l + ((-l).toNat : ℤ) = 0 from by omega] at h + exact h + -- the halting step + rw [show steps l r p = (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat + 1 + from rfl, + runFrom_add, e₅, runFrom_succ_eq_step', runFrom_zero, step_final hifp l r base G hl0, + eraseAbove_final l r G hG, eraseKeepAnchor_final l r hl0] + +include hifp in +/-- The configuration at every moment of the sweep: some sweep configuration, with the heads never +leaving the footprint interval widened by one cell, and live before the last step. -/ +private lemma run_shape (hl0 : l ≤ 0) (h0r : 0 ≤ r) (p : ℤ) (hlp : l ≤ p) (hpr : p ≤ r) + (hG : ∀ z, z < l ∨ r < z → G z = none) (m : ℕ) (hm : m ≤ steps l r p) : + ∃ (q : Option SweepState) (pos : ℤ) (Ti Tf : ℤ → Option Bool), + (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) m = + cfg i fp base q pos Ti Tf ∧ + l - 1 ≤ pos ∧ pos ≤ r + 1 ∧ (m < steps l r p → q ≠ none) := by + have hGr : eraseAbove G r = G := by + funext z + by_cases h : r < z + · simp [eraseAbove, h, hG z (Or.inr h)] + · simp [eraseAbove, h] + have hFr : eraseAbove (F l r) r = F l r := by + funext z + by_cases h : r < z + · have h0 : ¬ (z = 0) := by omega + have hin : ¬ (l ≤ z ∧ z ≤ r) := by omega + simp [eraseAbove, F, h, h0, hin] + · simp [eraseAbove, h] + -- the endpoints of the four walking segments + have chainA : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat) = cfg i fp base (some .goRight) (r + 1) G (F l r) := by + rw [run_goRight hifp l r base G p hlp ((r + 1 - p).toNat) (by omega), + show p + ((r + 1 - p).toNat : ℤ) = r + 1 from by omega] + have chainB : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1) = + cfg i fp base (some .toAnchor) r (eraseAbove G r) (eraseAbove (F l r) r) := by + rw [runFrom_add, chainA, runFrom_succ_eq_step', runFrom_zero, + step_turn hifp l r base G hl0 h0r, hGr, hFr] + have chainC : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1) = + cfg i fp base (some .sweepLeft) (-1) (eraseAbove G (-1)) + (eraseKeepAnchor (F l r) (-1)) := by + rw [runFrom_add, runFrom_add, chainB, + run_toAnchor hifp l r base G hl0 h0r r.toNat (by omega), + show r - (r.toNat : ℤ) = 0 from by omega, runFrom_succ_eq_step', runFrom_zero, + step_anchor hifp l r base G hl0 h0r] + have chainD : (sweep i fp).runFrom (cfg i fp base (some .goRight) p G (F l r)) + ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1) = + cfg i fp base (some .seek) l (eraseAbove G (l - 1)) + (eraseKeepAnchor (F l r) (l - 1)) := by + rw [runFrom_add, runFrom_add, chainC, + run_sweepLeft hifp l r base G hl0 h0r (-l).toNat (by omega), + show (-1 : ℤ) - ((-l).toNat : ℤ) = l - 1 from by omega, runFrom_succ_eq_step', + runFrom_zero, step_turnLeft hifp l r base G hl0] + have hs : steps l r p = + (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + (-l).toNat + 1 := rfl + -- case analysis on the segment `m` falls in + rcases Nat.lt_or_ge m ((r + 1 - p).toNat + 1) with h₁ | h₁ + · -- walking right + refine ⟨some .goRight, p + (m : ℤ), G, F l r, + run_goRight hifp l r base G p hlp m (by omega), by omega, by omega, fun _ => by simp⟩ + rcases Nat.lt_or_ge m ((r + 1 - p).toNat + 1 + r.toNat + 1) with h₂ | h₂ + · -- descending to the anchor + obtain ⟨d, hd, rfl⟩ : ∃ d : ℕ, (d : ℤ) ≤ r ∧ m = (r + 1 - p).toNat + 1 + d := + ⟨m - ((r + 1 - p).toNat + 1), by omega, by omega⟩ + rw [runFrom_add, chainB, run_toAnchor hifp l r base G hl0 h0r d hd] + exact ⟨_, _, _, _, rfl, by omega, by omega, fun _ => by simp⟩ + rcases Nat.lt_or_ge m ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1) with h₃ | h₃ + · -- descending below the anchor + obtain ⟨d, hd, rfl⟩ : ∃ d : ℕ, (d : ℤ) ≤ -l ∧ + m = (r + 1 - p).toNat + 1 + r.toNat + 1 + d := + ⟨m - ((r + 1 - p).toNat + 1 + r.toNat + 1), by omega, by omega⟩ + rw [runFrom_add, chainC, run_sweepLeft hifp l r base G hl0 h0r d hd] + exact ⟨_, _, _, _, rfl, by omega, by omega, fun _ => by simp⟩ + rcases Nat.lt_or_ge m (steps l r p) with h₄ | h₄ + · -- ascending to the anchor + obtain ⟨d, hd, rfl⟩ : ∃ d : ℕ, (d : ℤ) ≤ -l ∧ + m = (r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1 + d := + ⟨m - ((r + 1 - p).toNat + 1 + r.toNat + 1 + (-l).toNat + 1), by omega, by omega⟩ + rw [runFrom_add, chainD, run_seek hifp l r base G hl0 d hd] + exact ⟨_, _, _, _, rfl, by omega, by omega, fun _ => by simp⟩ + · -- the halting configuration + have hm' : m = steps l r p := by omega + subst hm' + exact ⟨none, 0, fun _ => none, fun _ => none, + run_full hifp l r base G hl0 h0r p hlp hpr hG, by omega, by omega, fun h => absurd h + (by omega)⟩ + +include hifp in +private lemma cfg_workTapePos_i (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapePos i = p := by + simp only [cfg] + rw [Function.update_of_ne hifp, Function.update_self] + +private lemma cfg_workTapePos_other (l' : Fin K) (hi : l' ≠ i) (hfp : l' ≠ fp) (q p Ti Tf) : + (cfg i fp base q p Ti Tf).workTapePos l' = base.workTapePos l' := by + simp only [cfg] + rw [Function.update_of_ne hfp, Function.update_of_ne hi] + +end Run + +end Sweep + +open Sweep in +/-- **Sweeping a footprinted pair clean.** Given a footprint over `[l, r]` with the anchor at `0` +on tape `fp`, and garbage confined to `[l, r]` on tape `i` — possibly with blanks inside, so that +no scan of tape `i` itself could find its extent — the sweep machine erases both tapes completely +and homes both heads to `0`, in time linear in the footprint interval and space exceeding it only +by a constant, touching nothing else. -/ +public theorem exists_sweepPair {K : ℕ} (i fp : Fin K) (hifp : i ≠ fp) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Bool State), + ∀ (input : List Bool) (c : Cfg K Bool State input) (l r p : ℤ), + c.state = some tm.q₀ → l ≤ 0 → 0 ≤ r → l ≤ p → p ≤ r → + c.workTapePos i = p → c.workTapePos fp = p → + (∀ z, c.workTapes fp z = if z = 0 then some true + else if l ≤ z ∧ z ≤ r then some false else none) → + (∀ z, z < l ∨ r < z → c.workTapes i z = none) → + ∃ u ≤ 4 * (r - l).toNat + 8, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, + Function.update (Function.update c.workTapes i fun _ => none) fp fun _ => none, + Function.update (Function.update c.workTapePos i 0) fp 0, + c.output⟩ ∧ + tm.spaceUsed c u ≤ 2 * (r - l).toNat + 4 + K := by + refine ⟨SweepState, inferInstance, sweep i fp, + fun input c l r p hq hl0 h0r hlp hpr hpi hpf hF hG => ?_⟩ + -- the start is a sweep configuration over the given data + have hFfun : c.workTapes fp = F l r := funext fun z => hF z + have hc : c = cfg i fp c (some .goRight) p (c.workTapes i) (F l r) := by + refine Cfg.ext hq rfl ?_ ?_ rfl + · rw [← hFfun] + simp [cfg, Function.update_eq_self] + · simp only [cfg] + funext l' + by_cases h1 : l' = fp + · subst h1; rw [Function.update_self]; exact hpf + · rw [Function.update_of_ne h1] + by_cases h2 : l' = i + · subst h2; rw [Function.update_self]; exact hpi + · rw [Function.update_of_ne h2] + -- the run, read back on `c` + have hrun : ∀ m ≤ steps l r p, ∃ (q' : Option SweepState) (pos : ℤ) + (Ti Tf : ℤ → Option Bool), + (sweep i fp).runFrom c m = cfg i fp c q' pos Ti Tf ∧ + l - 1 ≤ pos ∧ pos ≤ r + 1 ∧ (m < steps l r p → q' ≠ none) := by + intro m hm + obtain ⟨q', pos, Ti, Tf, heq, h1, h2, h3⟩ := + run_shape hifp l r c (c.workTapes i) hl0 h0r p hlp hpr hG m hm + rw [← hc] at heq + exact ⟨q', pos, Ti, Tf, heq, h1, h2, h3⟩ + have hfull : (sweep i fp).runFrom c (steps l r p) = + cfg i fp c none 0 (fun _ => none) (fun _ => none) := by + have h := run_full hifp l r c (c.workTapes i) hl0 h0r p hlp hpr hG + rwa [← hc] at h + refine ⟨steps l r p, by simp only [steps]; omega, ?_, ?_, ?_⟩ + · -- activity + intro m hm + obtain ⟨q', pos, Ti, Tf, heq, -, -, hq'⟩ := hrun m (by omega) + rw [heq] + simpa [cfg] using hq' hm + · -- the halting configuration + rw [hfull] + rfl + · -- the space bound + have hB : ∀ l' : Fin K, l' = i ∨ l' = fp → + (sweep i fp).spaceUsedByTape c (steps l r p) l' ≤ (r - l).toNat + 3 := by + intro l' hl' + have hsub : (sweep i fp).visitedByTapeHead c (steps l r p) l' ⊆ + Finset.Icc (l - 1) (r + 1) := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q', pos, Ti, Tf, heq, hlo, hhi, -⟩ := hrun m (by omega) + rw [heq] + rcases hl' with rfl | rfl + · rw [cfg_workTapePos_i hifp] + exact Finset.mem_Icc.mpr ⟨hlo, hhi⟩ + · rw [cfg_workTapePos_fp] + exact Finset.mem_Icc.mpr ⟨hlo, hhi⟩ + calc (sweep i fp).spaceUsedByTape c (steps l r p) l' + ≤ (Finset.Icc (l - 1) (r + 1)).card := Finset.card_le_card hsub + _ = (r + 1 + 1 - (l - 1)).toNat := Int.card_Icc _ _ + _ ≤ (r - l).toNat + 3 := by omega + have h1 : ∀ l' : Fin K, l' ≠ i → l' ≠ fp → + (sweep i fp).spaceUsedByTape c (steps l r p) l' ≤ 1 := by + intro l' hi' hfp' + have hsub : (sweep i fp).visitedByTapeHead c (steps l r p) l' ⊆ + {c.workTapePos l'} := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q', pos, Ti, Tf, heq, -, -, -⟩ := hrun m (by omega) + rw [heq, cfg_workTapePos_other c l' hi' hfp'] + exact Finset.mem_singleton_self _ + calc (sweep i fp).spaceUsedByTape c (steps l r p) l' + ≤ ({c.workTapePos l'} : Finset ℤ).card := Finset.card_le_card hsub + _ = 1 := Finset.card_singleton _ + have hfpmem : fp ∈ Finset.univ.erase i := + Finset.mem_erase.mpr ⟨Ne.symm hifp, Finset.mem_univ _⟩ + have hK : 2 ≤ K := by + rcases K with _ | _ | K + · exact i.elim0 + · exact absurd (Fin.ext (by omega : i.val = fp.val)) hifp + · omega + calc (sweep i fp).spaceUsed c (steps l r p) + = (sweep i fp).spaceUsedByTape c (steps l r p) i + + ∑ l' ∈ Finset.univ.erase i, (sweep i fp).spaceUsedByTape c (steps l r p) l' := + (Finset.add_sum_erase _ _ (Finset.mem_univ i)).symm + _ = (sweep i fp).spaceUsedByTape c (steps l r p) i + + ((sweep i fp).spaceUsedByTape c (steps l r p) fp + + ∑ l' ∈ (Finset.univ.erase i).erase fp, + (sweep i fp).spaceUsedByTape c (steps l r p) l') := by + rw [Finset.add_sum_erase _ _ hfpmem] + _ ≤ ((r - l).toNat + 3) + (((r - l).toNat + 3) + (K - 2) * 1) := by + have hcard : ((Finset.univ.erase i).erase fp).card = K - 1 - 1 := by + rw [Finset.card_erase_of_mem hfpmem, Finset.card_erase_of_mem (Finset.mem_univ i)] + simp + refine Nat.add_le_add (hB i (Or.inl rfl)) (Nat.add_le_add (hB fp (Or.inr rfl)) ?_) + calc ∑ l' ∈ (Finset.univ.erase i).erase fp, + (sweep i fp).spaceUsedByTape c (steps l r p) l' + ≤ ((Finset.univ.erase i).erase fp).card • 1 := + Finset.sum_le_card_nsmul _ _ 1 fun l' hl' => h1 l' + (Finset.ne_of_mem_erase (Finset.mem_of_mem_erase hl')) + (Finset.ne_of_mem_erase hl') + _ = (K - 2) * 1 := by rw [hcard]; simp; omega + _ ≤ 2 * (r - l).toNat + 4 + K := by omega + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean new file mode 100644 index 0000000000..c449bf2f07 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/NormalForms/Tidy.lean @@ -0,0 +1,747 @@ +/- +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 Mathlib.Basic.Finite.Sum +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Instrument +public import Cslib.Computability.Machines.Turing.MultiTape.NormalForms.Sweep +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.RewindInput +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.Sequential + +/-! +# The tidy normal form + +A machine given by `ComputesFunInTimeAndSpace` promises nothing about the configuration it halts +in: its work tapes hold garbage — possibly with blanks embedded, so that no scan can find its +extent — and its heads are wherever the run left them. A *tidy* machine halts in the fully +normalised configuration: work tapes blank, all heads back at the start, the input head rewound — +which is exactly a `Turing.MultiTapeTM.wordsCfg`. Tidiness is what the word-transformer interface +(`Turing.MultiTapeTM.TransformsTapes`) needs of a machine before it can be run on redirected +tapes: a tidy machine ends where the next one can begin. + +The normal-form theorem — every computable function has a tidy machine, at a constant-factor cost +in time and space — is the deep result of this directory. Its construction instruments the given +machine with one *footprint* tape per work tape, marking every visited cell in lockstep (the +footprint is contiguous because a head path is connected, restoring the scannability that garbage +lacks) with a distinguished anchor mark at cell `0`, and afterwards sweeps each pair clean, +outside-in towards the anchor. + +## Main definitions + +* `Turing.MultiTapeTM.TidyComputes`: the machine computes the function and halts tidily. + +## Main results + +* `Turing.MultiTapeTM.exists_tidy`: every computable function has a tidy machine, at a + constant-factor cost in time and space. +-/ + +namespace Turing.MultiTapeTM + +variable {α β : Type*} {k : ℕ} {Symbol State : Type*} + +/-- The machine computes `f` between the given encodings within the given bounds, and halts in the +fully normalised configuration: work tapes blank with heads at the start, input head rewound, the +encoded result as the output. -/ +@[expose] public def TidyComputes (tm : MultiTapeTM k Symbol State) + (encIn : α ↪ List Symbol) (encOut : β ↪ List Symbol) + (f : α → β) (t s : α → ℕ) : Prop := + ∀ a, ∃ τ ≤ t a, + tm.runFrom (tm.initCfg (encIn a)) τ = + wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + tm.spaceUsed (tm.initCfg (encIn a)) τ ≤ s a + +/-- A tidy machine computes its function in the ordinary sense: tidiness only adds constraints on +the halting configuration. -/ +public theorem TidyComputes.computesFunInTimeAndSpace + {tm : MultiTapeTM k Symbol State} {encIn : α ↪ List Symbol} {encOut : β ↪ List Symbol} + {f : α → β} {t s : α → ℕ} (h : TidyComputes tm encIn encOut f t s) : + ComputesFunInTimeAndSpace tm encIn encOut f t s := by + intro a + obtain ⟨τ, hτ, hrun, hspace⟩ := h a + exact ⟨τ, hτ, _, hspace, by rw [hrun]; rfl, by rw [hrun]; rfl, rfl⟩ + +section Assembly + +open Sequential + +variable {K : ℕ} {S₁ S₂ : Type} {input : List Bool} + +/-- The machine that halts on its first step, changing nothing. -/ +private def haltTM (K : ℕ) : MultiTapeTM K Bool Unit where + q₀ := () + tr _ _ _ := { inputTape := 0, workTapes := fun _ => (none, 0), output := none, state := none } + +private lemma haltTM_run (c : Cfg K Bool Unit input) (hc : c.state = some ()) : + (haltTM K).runFrom c 1 = c.withState (none : Option Unit) ∧ + (haltTM K).spaceUsed c 1 ≤ K := by + have hstep : (haltTM K).step c = c.withState (none : Option Unit) := by + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> simp [step, hc, Action.apply, haltTM, Cfg.withState] + have hrun : (haltTM K).runFrom c 1 = c.withState (none : Option Unit) := by + rw [runFrom_succ_eq_step', runFrom_zero, hstep] + refine ⟨hrun, spaceUsed_le_of_workTapePos_const _ _ fun m hm => ?_⟩ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rfl + · rw [hrun] + rfl + +section SweepChain + +variable {k₀ : ℕ} + +private lemma pair_ne {j j' : Fin k₀} (h : j' ≠ j) : + j'.castAdd k₀ ≠ j.castAdd k₀ ∧ j'.castAdd k₀ ≠ j.addNat k₀ ∧ + j'.addNat k₀ ≠ j.castAdd k₀ ∧ j'.addNat k₀ ≠ j.addNat k₀ := by + have hval : j'.val ≠ j.val := fun he => h (Fin.ext he) + have hj := j.isLt + have hj' := j'.isLt + refine ⟨?_, ?_, ?_, ?_⟩ <;> refine Fin.ne_of_val_ne ?_ <;> + simp only [Fin.val_castAdd, Fin.val_addNat] <;> omega + +set_option linter.style.haveILetI false in +/-- Sweeping a list of distinct footprinted pairs, one after the other. -/ +private lemma exists_sweepChain (k₀ : ℕ) (js : List (Fin k₀)) (hnd : js.Nodup) : + ∃ (S : Type) (_ : Finite S) (tm : MultiTapeTM (k₀ + k₀) Bool S), + ∀ (input : List Bool) (c : Cfg (k₀ + k₀) Bool S input) (L R P : Fin k₀ → ℤ), + c.state = some tm.q₀ → + (∀ j ∈ js, L j ≤ 0 ∧ 0 ≤ R j ∧ L j ≤ P j ∧ P j ≤ R j ∧ + c.workTapePos (j.castAdd k₀) = P j ∧ c.workTapePos (j.addNat k₀) = P j ∧ + (∀ z, c.workTapes (j.addNat k₀) z = if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none) ∧ + (∀ z, z < L j ∨ R j < z → c.workTapes (j.castAdd k₀) z = none)) → + ∃ u ≤ (js.map fun j => 4 * (R j - L j).toNat + 8).sum + 1, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, + js.foldl (fun w j => Function.update (Function.update w (j.castAdd k₀) + fun _ => none) (j.addNat k₀) fun _ => none) c.workTapes, + js.foldl (fun wp j => Function.update (Function.update wp (j.castAdd k₀) 0) + (j.addNat k₀) 0) c.workTapePos, + c.output⟩ ∧ + tm.spaceUsed c u ≤ + (js.map fun j => 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum + (k₀ + k₀) := by + induction js with + | nil => + refine ⟨Unit, inferInstance, haltTM (k₀ + k₀), fun input c L R P hq _ => ?_⟩ + obtain ⟨hrun, hsp⟩ := haltTM_run c hq + refine ⟨1, by simp, fun m hm => ?_, ?_, by simpa using hsp⟩ + · obtain rfl : m = 0 := by omega + rw [runFrom_zero, hq] + simp + · rw [hrun] + rfl + | cons j rest ih => + obtain ⟨hjr, hndr⟩ := List.nodup_cons.mp hnd + obtain ⟨Sr, hSr, tmr, hr⟩ := ih hndr + have hne : j.castAdd k₀ ≠ j.addNat k₀ := by + refine Fin.ne_of_val_ne ?_ + simp only [Fin.val_castAdd, Fin.val_addNat] + omega + obtain ⟨Ss, hSs, tms, hs⟩ := exists_sweepPair (j.castAdd k₀) (j.addNat k₀) hne + haveI := hSr + haveI := hSs + refine ⟨Ss ⊕ Sr, inferInstance, tms.seq tmr, fun input c L R P hq hpairs => ?_⟩ + obtain ⟨h1, h2, h3, h4, h5, h6, h7, h8⟩ := hpairs j (List.mem_cons_self) + -- run the sweep for the first pair + obtain ⟨u₁, hu₁, hact₁, hrun₁, hsp₁⟩ := hs input (c.withState (some tms.q₀)) + (L j) (R j) (P j) rfl h1 h2 h3 h4 h5 h6 h7 h8 + -- the rest of the pairs are untouched by the first sweep + have hrest : ∀ j' ∈ rest, L j' ≤ 0 ∧ 0 ≤ R j' ∧ L j' ≤ P j' ∧ P j' ≤ R j' ∧ + (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapePos (j'.castAdd k₀) = P j' ∧ + (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapePos (j'.addNat k₀) = P j' ∧ + (∀ z, (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapes (j'.addNat k₀) z = + if z = 0 then some true + else if L j' ≤ z ∧ z ≤ R j' then some false else none) ∧ + (∀ z, z < L j' ∨ R j' < z → + (⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ : Cfg (k₀ + k₀) Bool Sr input).workTapes (j'.castAdd k₀) z = none) := by + intro j' hj' + obtain ⟨g1, g2, g3, g4, g5, g6, g7, g8⟩ := hpairs j' (List.mem_cons_of_mem _ hj') + obtain ⟨n1, n2, n3, n4⟩ := pair_ne (j := j) (j' := j') (by rintro rfl; exact hjr hj') + refine ⟨g1, g2, g3, g4, ?_, ?_, fun z => ?_, fun z hz => ?_⟩ + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapePos (j'.castAdd k₀) = + (Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0) + (j'.castAdd k₀) from rfl, + Function.update_of_ne n2, Function.update_of_ne n1] + exact g5 + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapePos (j'.addNat k₀) = + (Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0) + (j'.addNat k₀) from rfl, + Function.update_of_ne n4, Function.update_of_ne n3] + exact g6 + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapes (j'.addNat k₀) = + (Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none) (j'.addNat k₀) from rfl, + Function.update_of_ne n4, Function.update_of_ne n3] + exact g7 z + · rw [show (⟨some tmr.q₀, c.inputPos, _, _, c.output⟩ : Cfg (k₀ + k₀) Bool Sr + input).workTapes (j'.castAdd k₀) = + (Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none) (j'.castAdd k₀) from rfl, + Function.update_of_ne n2, Function.update_of_ne n1] + exact g8 z hz + obtain ⟨u₂, hu₂, hact₂, hrun₂, hsp₂⟩ := + hr input ⟨some tmr.q₀, c.inputPos, + Function.update (Function.update c.workTapes (j.castAdd k₀) fun _ => none) + (j.addNat k₀) fun _ => none, + Function.update (Function.update c.workTapePos (j.castAdd k₀) 0) (j.addNat k₀) 0, + c.output⟩ L R P rfl hrest + -- glue the two runs + obtain ⟨hrunC, hactC, hspC⟩ := seq_spec (c := c) hq hrun₁ rfl hact₁ hsp₁ + hrun₂ rfl hact₂ hsp₂ + refine ⟨u₁ + u₂, ?_, hactC, ?_, ?_⟩ + · simp only [List.map_cons, List.sum_cons] + omega + · rw [hrunC] + rfl + · refine le_trans hspC ?_ + simp only [List.map_cons, List.sum_cons] + omega + +/-- Evaluating a fold of pairwise updates: a tape in one of the listed pairs got the new value, +any other keeps its old one. -/ +private lemma foldl_update_pair_eval {γ : Type*} {k₀ : ℕ} (js : List (Fin k₀)) (b : γ) + (w : Fin (k₀ + k₀) → γ) (l : Fin (k₀ + k₀)) : + js.foldl (fun w' j => Function.update (Function.update w' (j.castAdd k₀) b) + (j.addNat k₀) b) w l = + if ∃ j ∈ js, l = j.castAdd k₀ ∨ l = j.addNat k₀ then b else w l := by + induction js generalizing w with + | nil => simp + | cons j rest ih => + rw [List.foldl_cons, ih] + by_cases hmem : ∃ j' ∈ rest, l = j'.castAdd k₀ ∨ l = j'.addNat k₀ + · rw [ite_eq_left hmem, ite_eq_left ?_] + obtain ⟨j', hj', hl⟩ := hmem + exact ⟨j', List.mem_cons_of_mem _ hj', hl⟩ + · rw [ite_eq_right hmem] + by_cases h1 : l = j.addNat k₀ + · subst h1 + rw [Function.update_self, ite_eq_left ⟨j, List.mem_cons_self, Or.inr rfl⟩] + · rw [Function.update_of_ne h1] + by_cases h2 : l = j.castAdd k₀ + · subst h2 + rw [Function.update_self, ite_eq_left ⟨j, List.mem_cons_self, Or.inl rfl⟩] + · rw [Function.update_of_ne h2, ite_eq_right ?_] + rintro ⟨j', hj', hl⟩ + rcases List.mem_cons.mp hj' with rfl | hj' + · exact hl.elim h2 h1 + · exact hmem ⟨j', hj', hl⟩ + +/-- Every tape belongs to one of the pairs. -/ +private lemma exists_pair_mem {k₀ : ℕ} (l : Fin (k₀ + k₀)) : + ∃ j ∈ List.finRange k₀, l = j.castAdd k₀ ∨ l = j.addNat k₀ := by + induction l using Fin.addCases with + | left j => exact ⟨j, List.mem_finRange j, Or.inl rfl⟩ + | right j => exact ⟨j, List.mem_finRange j, Or.inr (by rw [Fin.natAdd_eq_addNat])⟩ + +end SweepChain + +set_option linter.style.haveILetI false in +/-- **The tidy normal form theorem.** Every computable function has a tidy machine, at a +constant-factor cost in time and space: anchor the footprints, run the instrumented machine, +mark the final head positions, rewind the input head, and sweep every pair clean. -/ +public theorem exists_tidy {α β : Type*} {encIn : α ↪ List Bool} {encOut : β ↪ List Bool} + {f : α → β} {t s : α → ℕ} (h : ComputableInTimeAndSpace f encIn encOut t s) : + ∃ (c k : ℕ) (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), + TidyComputes tm encIn encOut f + (fun a => c * (t a + 1)) (fun a => c * (s a + 1) + k) := by + classical + obtain ⟨k₀, State₀, hfin₀, tm₀, hfun⟩ := h + obtain ⟨SA, hSA, tmA, hA⟩ := exists_markAnchors k₀ Bool true + obtain ⟨SC, hSC, tmC, hC⟩ := exists_markCurrent k₀ Bool false + obtain ⟨SD, hSD, tmD, hD⟩ := exists_rewindInput (k₀ + k₀) Bool + obtain ⟨SE, hSE, tmE, hE⟩ := exists_sweepChain k₀ (List.finRange k₀) (List.nodup_finRange k₀) + haveI := hfin₀; haveI := hSA; haveI := hSC; haveI := hSD; haveI := hSE + refine ⟨20 * (k₀ + 1) * (k₀ + 1), k₀ + k₀, + SA ⊕ (State₀ ⊕ (SC ⊕ (SD ⊕ SE))), inferInstance, + tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))), fun a => ?_⟩ + -- the run of the original machine, at its first halting time + obtain ⟨t', ht', s', hs', hhalt', hout', hspace'⟩ := hfun a + obtain ⟨u₀, hu₀, hhalt₀, hact₀⟩ := + exists_minimal_halting_time tm₀ (tm₀.initCfg (encIn a)) t' hhalt' + have hout₀ : (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).output = encOut (f a) := by + rw [← runFrom_eq_of_halt tm₀ (tm₀.initCfg (encIn a)) hu₀ hhalt₀] + exact hout' + have hsp₀ : tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ ≤ s a := by + have hm : tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ ≤ + tm₀.spaceUsed (tm₀.initCfg (encIn a)) t' := + spaceUsed_mono tm₀ (tm₀.initCfg (encIn a)) hu₀ + omega + -- the visited interval and final head position of each tape + choose L R hL0 h0R hIcc using + fun j => exists_visitedByTapeHead_eq_Icc (tm := tm₀) (tm₀.initCfg (encIn a)) u₀ j + set P : Fin k₀ → ℤ := fun j => (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapePos j with hP + have hPmem : ∀ j, L j ≤ P j ∧ P j ≤ R j := by + intro j + have hmem := tm₀.mem_visitedByTapeHead_self (tm₀.initCfg (encIn a)) u₀ j + rw [hIcc j] at hmem + exact Finset.mem_Icc.mp hmem + have hGconf : ∀ j z, z < L j ∨ R j < z → + (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j z = none := by + intro j z hz + by_contra hne + have hmem : z ∈ tm₀.visitedByTapeHead (tm₀.initCfg (encIn a)) u₀ j := + tm₀.mem_visitedByTapeHead_of_workTapes_ne j u₀ z hne + rw [hIcc j] at hmem + have := Finset.mem_Icc.mp hmem + omega + -- phase A: place the anchors + obtain ⟨eAstate, eAip, eAout, eApos, eAcast, eAanchor⟩ := hA (encIn a) + (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) rfl + -- the interval data, in usable form + have hL0' : ∀ j, L j ≤ 0 := fun j => by simpa [Cfg.init] using hL0 j + have h0R' : ∀ j, 0 ≤ R j := fun j => by simpa [Cfg.init] using h0R j + -- phases D and E, from any configuration with the right fields + have hDE : ∀ (c : Cfg (k₀ + k₀) Bool (SD ⊕ SE) (encIn a)), + c.state = some (tmD.seq tmE).q₀ → + c.inputPos.val ≤ u₀ + 1 → + c.output = encOut (f a) → + (∀ j, c.workTapes (j.castAdd k₀) = (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j) → + (∀ j z, c.workTapes (j.addNat k₀) z = if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none) → + (∀ j, c.workTapePos (j.castAdd k₀) = P j) → + (∀ j, c.workTapePos (j.addNat k₀) = P j) → + ∃ u ≤ (u₀ + 3) + + (((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum + 1), + (tmD.seq tmE).runFrom c u = wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + (∀ m < u, ((tmD.seq tmE).runFrom c m).state ≠ none) ∧ + (tmD.seq tmE).spaceUsed c u ≤ (k₀ + k₀) + + ((((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum) + (k₀ + k₀)) := by + intro c hstate hip hout hcast hfp hposc hposn + -- rewind the input head + obtain ⟨uD, huD, hactD, hrunD, hframeD⟩ := hD (encIn a) (c.withState (some tmD.q₀)) rfl + -- sweep every pair + have hpairsE : ∀ j ∈ List.finRange k₀, L j ≤ 0 ∧ 0 ≤ R j ∧ L j ≤ P j ∧ P j ≤ R j ∧ + ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapePos (j.castAdd k₀) = P j ∧ + ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapePos (j.addNat k₀) = P j ∧ + (∀ z, ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapes (j.addNat k₀) z = if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none) ∧ + (∀ z, z < L j ∨ R j < z → ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapes (j.castAdd k₀) z = none) := by + intro j _ + refine ⟨hL0' j, h0R' j, (hPmem j).1, (hPmem j).2, hposc j, hposn j, fun z => hfp j z, + fun z hz => ?_⟩ + rw [show ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState + (some tmE.q₀)).workTapes (j.castAdd k₀) = c.workTapes (j.castAdd k₀) from rfl, + hcast j] + exact hGconf j z hz + obtain ⟨uE, huE, hactE, hrunE, hspE⟩ := hE (encIn a) + ((⟨none, 1, (c.withState (some tmD.q₀)).workTapes, + (c.withState (some tmD.q₀)).workTapePos, (c.withState (some tmD.q₀)).output⟩ : + Cfg (k₀ + k₀) Bool SD (encIn a)).withState (some tmE.q₀)) L R P rfl hpairsE + -- glue the two phases + obtain ⟨hrunC, hactC, hspC⟩ := seq_spec hstate hrunD rfl hactD + (spaceUsed_le_of_workTapePos_const _ _ fun m hm => (hframeD m hm).2.1) + hrunE rfl hactE hspE + have huD' : uD ≤ c.inputPos.val + 2 := by simpa using huD + refine ⟨uD + uE, by omega, ?_, hactC, le_trans hspC (by omega)⟩ + rw [hrunC] + -- the swept configuration is the tidy one + refine Cfg.ext rfl rfl ?_ ?_ ?_ + · funext l + exact ((foldl_update_pair_eval (List.finRange k₀) (fun _ => none) + ((c.withState (some tmD.q₀)).workTapes) l).trans + (by rw [ite_eq_left (exists_pair_mem l)])).trans tapeOfList_nil.symm + · funext l + exact (foldl_update_pair_eval (List.finRange k₀) 0 + ((c.withState (some tmD.q₀)).workTapePos) l).trans + (by rw [ite_eq_left (exists_pair_mem l)]; rfl) + · exact hout + -- the marks laid down before the final step, together with the final position, are the interval + have hmarksIccT : ∀ (j : Fin k₀) (z : ℤ), + ((z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j)) ∨ z = P j) ↔ + (L j ≤ z ∧ z ≤ R j) := by + intro j z + rw [show (L j ≤ z ∧ z ≤ R j) ↔ z ∈ Finset.Icc (L j) (R j) from (Finset.mem_Icc).symm, + ← hIcc j, mem_visitedByTapeHead] + constructor + · rintro (hz | rfl) + · obtain ⟨m, hm, rfl⟩ := Finset.mem_image.mp hz + exact ⟨m, by have := Finset.mem_range.mp hm; omega, rfl⟩ + · exact ⟨u₀, by omega, rfl⟩ + · rintro ⟨m, hm, rfl⟩ + rcases Nat.lt_or_ge m u₀ with hlt | hge + · exact Or.inl (Finset.mem_image.mpr ⟨m, Finset.mem_range.mpr hlt, rfl⟩) + · right + rw [show m = u₀ from by omega] + -- phases C, D and E: mark the final positions, then rewind and sweep + have hCDE : ∀ (c : Cfg (k₀ + k₀) Bool (SC ⊕ (SD ⊕ SE)) (encIn a)), + c.state = some (tmC.seq (tmD.seq tmE)).q₀ → + c.inputPos.val ≤ u₀ + 1 → + c.output = encOut (f a) → + (∀ j, c.workTapes (j.castAdd k₀) = (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j) → + (∀ j z, c.workTapes (j.addNat k₀) z = if z = 0 then some true + else if z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) then some false + else none) → + (∀ j, c.workTapePos (j.castAdd k₀) = P j) → + (∀ j, c.workTapePos (j.addNat k₀) = P j) → + ∃ u ≤ 1 + ((u₀ + 3) + + (((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum + 1)), + (tmC.seq (tmD.seq tmE)).runFrom c u = + wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + (∀ m < u, ((tmC.seq (tmD.seq tmE)).runFrom c m).state ≠ none) ∧ + (tmC.seq (tmD.seq tmE)).spaceUsed c u ≤ (k₀ + k₀) + ((k₀ + k₀) + + ((((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum) + (k₀ + k₀))) := by + intro c hstate hip hout hcast hfp hposc hposn + obtain ⟨eCstate, eCip, eCout, eCpos, eCcast, eCmark⟩ := + hC (encIn a) (c.withState (some tmC.q₀)) rfl + -- after the mark, the footprints are exactly the intervals + have hfpC : ∀ (j : Fin k₀) (z : ℤ), + (tmC.runFrom (c.withState (some tmC.q₀)) 1).workTapes (j.addNat k₀) z = + if z = 0 then some true + else if L j ≤ z ∧ z ≤ R j then some false else none := by + intro j z + have hthis := congrFun (eCmark j) z + simp only [Cfg.withState_workTapes, Cfg.withState_workTapePos] at hthis + rw [hposn j, hfp j z, hfp j (P j)] at hthis + rw [hthis] + by_cases hz : z = 0 + · subst hz + simp + · simp only [ite_eq_right hz] + by_cases hmem : z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) + · rw [ite_eq_left hmem, ite_eq_left ((hmarksIccT j z).mp (Or.inl hmem))] + · rw [ite_eq_right hmem] + by_cases hzP : z = P j + · subst hzP + rw [ite_eq_right hz, ite_eq_right hmem, ite_eq_left ⟨rfl, rfl⟩, + ite_eq_left ((hmarksIccT j (P j)).mp (Or.inr rfl))] + · have hnot : ¬ (L j ≤ z ∧ z ≤ R j) := by + intro hin + rcases (hmarksIccT j z).mpr hin with hm | hm + · exact hmem hm + · exact hzP hm + rw [ite_eq_right hnot, ite_eq_right (fun hcond => hzP hcond.1)] + -- hand over to the rewind and the sweeps + obtain ⟨u₂, hu₂, hrun₂, hact₂, hsp₂⟩ := hDE + ((tmC.runFrom (c.withState (some tmC.q₀)) 1).withState (some (tmD.seq tmE).q₀)) + rfl + ((by + rw [eCip] + simpa using hip) : + ((tmC.runFrom (c.withState (some tmC.q₀)) 1).inputPos : ℕ) ≤ u₀ + 1) + ((by + rw [eCout] + simpa using hout) : + (tmC.runFrom (c.withState (some tmC.q₀)) 1).output = encOut (f a)) + (fun j => (eCcast j).trans (hcast j)) + (fun j z => hfpC j z) + (fun j => ((by + rw [eCpos] + simpa using hposc j) : + (tmC.runFrom (c.withState (some tmC.q₀)) 1).workTapePos (j.castAdd k₀) = P j)) + (fun j => ((by + rw [eCpos] + simpa using hposn j) : + (tmC.runFrom (c.withState (some tmC.q₀)) 1).workTapePos (j.addNat k₀) = P j)) + obtain ⟨hrunG, hactG, hspG⟩ := seq_spec hstate rfl eCstate + (fun m hm => by + obtain rfl : m = 0 := by omega + rw [runFrom_zero] + simp) + (spaceUsed_le_of_workTapePos_const _ _ fun m hm => by + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · exact eCpos) + hrun₂ rfl hact₂ hsp₂ + refine ⟨1 + u₂, by omega, ?_, hactG, le_trans hspG (by omega)⟩ + rw [hrunG] + rfl + -- phases B to E: the instrumented run, then the cleanup + have hBCDE : ∀ (c : Cfg (k₀ + k₀) Bool (State₀ ⊕ (SC ⊕ (SD ⊕ SE))) (encIn a)), + c.state = some ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).q₀ → + c.inputPos = 1 → + (∀ j : Fin k₀, c.workTapes (j.castAdd k₀) = fun _ => none) → + (∀ (j : Fin k₀) (z : ℤ), c.workTapes (j.addNat k₀) z = + if z = 0 then some true else none) → + (∀ l, c.workTapePos l = 0) → + c.output = [] → + ∃ u ≤ u₀ + (1 + ((u₀ + 3) + + (((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum + 1))), + ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).runFrom c u = + wordsCfg (encIn a) none (fun _ => []) (encOut (f a)) ∧ + (∀ m < u, (((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).runFrom c m).state ≠ + none) ∧ + ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).spaceUsed c u ≤ + 2 * s a + ((k₀ + k₀) + ((k₀ + k₀) + + ((((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum) + (k₀ + k₀)))) := by + intro c hstate hip hcastB hanchorB hposB houtB + -- the instrumented start projects to the original start + have hproj : projCfg (c.withState (some tm₀.q₀)) = tm₀.initCfg (encIn a) := by + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simpa using hip + · funext j z + simpa using congrFun (hcastB j) z + · funext j + simpa using hposB (j.castAdd k₀) + · simpa using houtB + have hmirror : ∀ m, tm₀.runFrom (tm₀.initCfg (encIn a)) m = + projCfg ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) m) := by + intro m + rw [← hproj] + exact runFrom_projCfg tm₀ false (c.withState (some tm₀.q₀)) m + have hstateB : ∀ m, ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) m).state = + (tm₀.runFrom (tm₀.initCfg (encIn a)) m).state := by + intro m + rw [hmirror m] + rfl + have hactB : ∀ m < u₀, + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) m).state ≠ none := by + intro m hm + rw [hstateB] + exact hact₀ m hm + have hhaltB : ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).state = + none := by + rw [hstateB] + exact hhalt₀ + have halignB : ∀ j : Fin k₀, (c.withState (some tm₀.q₀)).workTapePos (j.addNat k₀) = + (c.withState (some tm₀.q₀)).workTapePos (j.castAdd k₀) := by + intro j + have h1 := hposB (j.addNat k₀) + have h2 := hposB (j.castAdd k₀) + simp only [Cfg.withState_workTapePos] + omega + -- hand over to the marking, the rewind and the sweeps + obtain ⟨u₂, hu₂, hrun₂, hact₂, hsp₂⟩ := hCDE + (((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).withState + (some (tmC.seq (tmD.seq tmE)).q₀)) + rfl + ((by + rw [show ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).inputPos = + (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).inputPos from by rw [hmirror u₀]; rfl] + have h := inputPos_runFrom_le tm₀ (tm₀.initCfg (encIn a)) u₀ + have h2 : ((tm₀.initCfg (encIn a)).inputPos : ℕ) = 1 := rfl + omega) : + (((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).inputPos : ℕ) ≤ + u₀ + 1) + ((by + rw [show ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).output = + (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).output from by rw [hmirror u₀]; rfl] + exact hout₀) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).output = encOut (f a)) + (fun j => ((by rw [hmirror u₀]; rfl) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapes + (j.castAdd k₀) = (tm₀.runFrom (tm₀.initCfg (encIn a)) u₀).workTapes j)) + (fun j z => ((by + rw [congrFun (workTapes_addNat_instrument (c.withState (some tm₀.q₀)) j (halignB j) + u₀ hactB) z] + rw [show (c.withState (some tm₀.q₀)).workTapes (j.addNat k₀) z = + c.workTapes (j.addNat k₀) z from rfl, hanchorB j z] + have himg : (Finset.range u₀).image + (fun m => ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) + m).workTapePos (j.castAdd k₀)) = + (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) := by + refine Finset.image_congr fun m _ => ?_ + rw [hmirror m] + rfl + rw [himg] + by_cases hz : z = 0 + · subst hz + simp + · simp only [ite_eq_right hz]) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapes + (j.addNat k₀) z = if z = 0 then some true + else if z ∈ (Finset.range u₀).image + (fun m => (tm₀.runFrom (tm₀.initCfg (encIn a)) m).workTapePos j) then some false + else none)) + (fun j => ((by + simp only [hP] + rw [hmirror u₀] + rfl) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapePos + (j.castAdd k₀) = P j)) + (fun j => ((by + rw [workTapePos_addNat_instrument (c.withState (some tm₀.q₀)) j (halignB j) u₀ hactB] + simp only [hP] + rw [hmirror u₀] + rfl) : + ((tm₀.instrument false).runFrom (c.withState (some tm₀.q₀)) u₀).workTapePos + (j.addNat k₀) = P j)) + have hspB : (tm₀.instrument false).spaceUsed (c.withState (some tm₀.q₀)) u₀ ≤ 2 * s a := by + rw [spaceUsed_instrument tm₀ false (c.withState (some tm₀.q₀)) u₀ halignB hactB, hproj] + omega + obtain ⟨hrunG, hactG, hspG⟩ := seq_spec hstate rfl hhaltB hactB hspB hrun₂ + rfl hact₂ hsp₂ + refine ⟨u₀ + u₂, by omega, ?_, hactG, le_trans hspG (by omega)⟩ + rw [hrunG] + rfl + -- the interval sums, bounded by the original machine's space + have hcard : ∀ j, (R j - L j).toNat + 1 = + tm₀.spaceUsedByTape (tm₀.initCfg (encIn a)) u₀ j := by + intro j + rw [spaceUsedByTape, hIcc j, Int.card_Icc] + have h1 := hL0' j + have h2 := h0R' j + omega + have hsumX : (∑ j : Fin k₀, (R j - L j).toNat) + k₀ = + tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ := by + have h1 : (∑ j : Fin k₀, ((R j - L j).toNat + 1)) = + tm₀.spaceUsed (tm₀.initCfg (encIn a)) u₀ := + Finset.sum_congr rfl fun j _ => hcard j + rw [Finset.sum_add_distrib] at h1 + simpa using h1 + have hsX_s : (∑ j : Fin k₀, (R j - L j).toNat) ≤ s a := by omega + have hsX_t : (∑ j : Fin k₀, (R j - L j).toNat) ≤ k₀ * u₀ := by + have hlin := spaceUsed_linear (tm := tm₀) (tm₀.initCfg (encIn a)) u₀ + omega + have hs4 : ((List.finRange k₀).map fun j => 4 * (R j - L j).toNat + 8).sum = + 4 * (∑ j : Fin k₀, (R j - L j).toNat) + 8 * k₀ := by + rw [← Fin.sum_univ_def, Finset.sum_add_distrib, ← Finset.mul_sum] + simp [mul_comm] + have hs2 : ((List.finRange k₀).map fun j => 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum = + 2 * (∑ j : Fin k₀, (R j - L j).toNat) + (4 + (k₀ + k₀)) * k₀ := by + rw [← Fin.sum_univ_def, + show (fun j : Fin k₀ => 2 * (R j - L j).toNat + 4 + (k₀ + k₀)) = + (fun j => 2 * (R j - L j).toNat + (4 + (k₀ + k₀))) from funext fun j => by omega, + Finset.sum_add_distrib, ← Finset.mul_sum] + simp [mul_comm] + -- discharge phase A and glue at the top + obtain ⟨u₂, hu₂, hrun₂, hact₂, hsp₂⟩ := hBCDE + ((tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).withState + (some ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE))).q₀)) + rfl + ((by rw [eAip]; rfl) : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).inputPos = 1) + (fun j => (eAcast j : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).workTapes (j.castAdd k₀) = fun _ => none)) + (fun j z => ((by + rw [congrFun (eAanchor j) z, + show (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)).workTapePos (j.addNat k₀) = (0 : ℤ) from rfl] + by_cases hz : z = 0 + · subst hz + rw [Function.update_self] + simp + · rw [Function.update_of_ne hz, ite_eq_right hz] + rfl) : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).workTapes (j.addNat k₀) z = + if z = 0 then some true else none)) + (fun l => (congrFun eApos l : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).workTapePos l = 0)) + (eAout : + (tmA.runFrom (((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg + (encIn a)).withState (some tmA.q₀)) 1).output = []) + obtain ⟨hrunT, hactT, hspT⟩ := seq_spec + (c := (tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg (encIn a)) + rfl rfl eAstate + (fun m hm => by + obtain rfl : m = 0 := by omega + rw [runFrom_zero] + simp) + (spaceUsed_le_of_workTapePos_const _ _ fun m hm => by + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · exact eApos) + hrun₂ rfl hact₂ hsp₂ + -- assemble the run and the bounds + have hkk : k₀ ≤ (k₀ + 1) * (k₀ + 1) := by + have h := Nat.le_mul_of_pos_left (k₀ + 1) (show 0 < k₀ + 1 by omega) + omega + have hM : ∀ v x : ℕ, (x ≤ k₀ * v ∨ x ≤ v ∨ x ≤ k₀ * k₀ ∨ x ≤ k₀ ∨ x ≤ 1) → + x ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := by + intro v x hx + have h1 : k₀ * v ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := Nat.mul_le_mul hkk (by omega) + have h2 : v + 1 ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := + Nat.le_mul_of_pos_left (v + 1) (Nat.mul_pos (by omega) (by omega)) + have h3 : k₀ * k₀ ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := by + have ha : k₀ * k₀ ≤ (k₀ + 1) * (k₀ + 1) := Nat.mul_le_mul (by omega) (by omega) + have hb : (k₀ + 1) * (k₀ + 1) ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := + Nat.le_mul_of_pos_right _ (by omega) + omega + have h4 : k₀ ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := by + have hb : (k₀ + 1) * (k₀ + 1) ≤ (k₀ + 1) * (k₀ + 1) * (v + 1) := + Nat.le_mul_of_pos_right _ (by omega) + omega + omega + refine ⟨1 + u₂, ?_, ?_, ?_⟩ + · -- the time bound + change 1 + u₂ ≤ 20 * (k₀ + 1) * (k₀ + 1) * (t a + 1) + rw [hs4] at hu₂ + have hb : 1 + u₂ ≤ 4 * (k₀ * u₀) + (2 * u₀ + (8 * k₀ + 6)) := by omega + have m1 := hM u₀ (k₀ * u₀) (Or.inl le_rfl) + have m2 := hM u₀ u₀ (Or.inr (Or.inl le_rfl)) + have m3 := hM u₀ k₀ (Or.inr (Or.inr (Or.inr (Or.inl le_rfl)))) + have m4 := hM u₀ 1 (Or.inr (Or.inr (Or.inr (Or.inr le_rfl)))) + have hbig : 1 + u₂ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (u₀ + 1)) := by omega + have hmono : 20 * ((k₀ + 1) * (k₀ + 1) * (u₀ + 1)) ≤ + 20 * ((k₀ + 1) * (k₀ + 1) * (t a + 1)) := + Nat.mul_le_mul_left _ (Nat.mul_le_mul_left _ (by omega)) + calc 1 + u₂ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (u₀ + 1)) := hbig + _ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (t a + 1)) := hmono + _ = 20 * (k₀ + 1) * (k₀ + 1) * (t a + 1) := by rw [← mul_assoc, ← mul_assoc] + · -- the halting configuration + rw [hrunT] + rfl + · -- the space bound + change (tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).spaceUsed + ((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg (encIn a)) + (1 + u₂) ≤ 20 * (k₀ + 1) * (k₀ + 1) * (s a + 1) + (k₀ + k₀) + have hs2' : ((List.finRange k₀).map fun j => + 2 * (R j - L j).toNat + 4 + (k₀ + k₀)).sum = + 2 * (∑ j : Fin k₀, (R j - L j).toNat) + (4 * k₀ + (k₀ * k₀ + k₀ * k₀)) := by + rw [hs2, Nat.add_mul, Nat.add_mul] + rw [hs2'] at hspT + have m1 := hM (s a) (s a) (Or.inr (Or.inl le_rfl)) + have m2 := hM (s a) (k₀ * k₀) (Or.inr (Or.inr (Or.inl le_rfl))) + have m3 := hM (s a) k₀ (Or.inr (Or.inr (Or.inr (Or.inl le_rfl)))) + have hbig : (tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).spaceUsed + ((tmA.seq ((tm₀.instrument false).seq (tmC.seq (tmD.seq tmE)))).initCfg (encIn a)) + (1 + u₂) ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (s a + 1)) := by omega + calc _ ≤ 20 * ((k₀ + 1) * (k₀ + 1) * (s a + 1)) := hbig + _ ≤ 20 * (k₀ + 1) * (k₀ + 1) * (s a + 1) + (k₀ + k₀) := by + rw [← mul_assoc, ← mul_assoc] + omega + + +end Assembly + + + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean new file mode 100644 index 0000000000..14f752ab6c --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Branch.lean @@ -0,0 +1,258 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Mathlib.Data.Fintype.Option +public import Mathlib.Basic.Finite.Sum + +/-! +# Branching combinators + +`branch i x tm₁ tm₂` first reads one symbol — the one under the head of work tape `i` — then, +depending on whether it equals `some x`, behaves like `tm₁` or like `tm₂`, each started in its +initial state on the tapes as they were. + +It is a control combinator analogous to sequential composition (`Plumbing/Sequential.lean`): the +state space adds a fresh dispatch state on top of `State₁ ⊕ State₂`, the dispatch is one step that +writes nothing and moves no head, and afterwards the machine mirrors the chosen sub-machine through +a left/right embedding just as `seq` mirrors its second machine. It is an instance of a single +machine `armed d` parameterised by the dispatch decision `d`, and the arm-mirroring semiconjugation +is proved once, for all `d`. + +Because at a starting `wordsCfg` the head of every work tape sits at the start of its word, tape +`i`'s symbol there is exactly `(ws i).head?`, so the dispatch reads precisely the predicate its +specification branches on. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_branch`: from two transformations sharing a + postcondition, a single machine that runs one or the other according to the symbol under tape + `i`, with the time bound `max t₁ t₂ + 1` and the space bound `max s₁ s₂ + k`. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {S₁ S₂ : Type*} {input : List Bool} + +namespace Branch + +/-- The shared branching machine, parameterised by a dispatch decision `d`. State `none` is a fresh +dispatch state: it reads the input symbol and the work-tape symbols and, in one step that writes +nothing and moves no head, jumps to the sub-machine's initial state chosen by `d`. Thereafter it +mirrors the chosen machine, its states carried by `Sum.inl`/`Sum.inr`. -/ +private def armed (d : Option Bool → (Fin k → Option Bool) → S₁ ⊕ S₂) + (tm₁ : MultiTapeTM k Bool S₁) (tm₂ : MultiTapeTM k Bool S₂) : + MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) where + q₀ := none + tr q inp work := + match q with + | none => + { inputTape := 0 + workTapes := fun _ => (none, 0) + output := none + state := some (some (d inp work)) } + | some (Sum.inl q₁) => + let a := tm₁.tr q₁ inp work + { a with state := a.state.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂))) } + | some (Sum.inr q₂) => + let a := tm₂.tr q₂ inp work + { a with state := a.state.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂))) } + +variable {d : Option Bool → (Fin k → Option Bool) → S₁ ⊕ S₂} + {tm₁ : MultiTapeTM k Bool S₁} {tm₂ : MultiTapeTM k Bool S₂} + +/-- A configuration of `tm₁`, embedded into the branching machine: a halted state stays halted, a +live state is carried by `Sum.inl`. -/ +private def leftCfg (cfg : Cfg k Bool S₁ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := + cfg.mapState (Option.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) + +/-- A configuration of `tm₂`, embedded into the branching machine. -/ +private def rightCfg (cfg : Cfg k Bool S₂ input) : Cfg k Bool (Option (S₁ ⊕ S₂)) input := + cfg.mapState (Option.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) + +@[simp] +private lemma workTapePos_leftCfg (cfg : Cfg k Bool S₁ input) : + (leftCfg (S₂ := S₂) cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +private lemma workTapePos_rightCfg (cfg : Cfg k Bool S₂ input) : + (rightCfg (S₁ := S₁) cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +private lemma leftCfg_wordsCfg (q : Option S₁) (ws : Fin k → List Bool) (out : List Bool) : + leftCfg (S₂ := S₂) (wordsCfg input q ws out) = + wordsCfg input (q.map (fun s => (some (Sum.inl s) : Option (S₁ ⊕ S₂)))) ws out := rfl + +@[simp] +private lemma rightCfg_wordsCfg (q : Option S₂) (ws : Fin k → List Bool) (out : List Bool) : + rightCfg (S₁ := S₁) (wordsCfg input q ws out) = + wordsCfg input (q.map (fun s => (some (Sum.inr s) : Option (S₁ ⊕ S₂)))) ws out := rfl + +/-- On `tm₁`'s configurations, the branching machine mirrors `tm₁` step for step. This holds for +every dispatch `d`, since it only touches the live `Sum.inl` states, whose transition is +independent of `d`. -/ +private lemma step_leftCfg (cfg : Cfg k Bool S₁ input) : + (armed d tm₁ tm₂).step (leftCfg cfg) = leftCfg (tm₁.step cfg) := by + cases hq : cfg.state with + | none => + rw [step_of_halt (by simp [leftCfg, hq]), step_of_halt hq] + | some q => + have h1 : (leftCfg (S₂ := S₂) cfg).state = some (some (Sum.inl q)) := by simp [leftCfg, hq] + simp only [step, h1, hq] + rfl + +/-- On `tm₂`'s configurations, the branching machine mirrors `tm₂` step for step. -/ +private lemma step_rightCfg (cfg : Cfg k Bool S₂ input) : + (armed d tm₁ tm₂).step (rightCfg cfg) = rightCfg (tm₂.step cfg) := by + cases hq : cfg.state with + | none => + rw [step_of_halt (by simp [rightCfg, hq]), step_of_halt hq] + | some q => + have h1 : (rightCfg (S₁ := S₁) cfg).state = some (some (Sum.inr q)) := by simp [rightCfg, hq] + simp only [step, h1, hq] + rfl + +private lemma runFrom_leftCfg (cfg : Cfg k Bool S₁ input) (n : ℕ) : + (armed d tm₁ tm₂).runFrom (leftCfg cfg) n = leftCfg (tm₁.runFrom cfg n) := + runFrom_comm_of_step leftCfg (fun c => step_leftCfg c) cfg n + +private lemma runFrom_rightCfg (cfg : Cfg k Bool S₂ input) (n : ℕ) : + (armed d tm₁ tm₂).runFrom (rightCfg cfg) n = rightCfg (tm₂.runFrom cfg n) := + runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n + +/-! ### The work-tape branch -/ + +/-- The branching machine. State `none` is a fresh dispatch state: it reads the symbol under tape +`i`'s head and, in one step that writes nothing and moves no head, jumps to `tm₁`'s initial state +(if the symbol is `some x`) or `tm₂`'s (otherwise). Thereafter it mirrors the chosen machine, its +states carried by `Sum.inl`/`Sum.inr`. -/ +private abbrev branch (i : Fin k) (x : Bool) (tm₁ : MultiTapeTM k Bool S₁) + (tm₂ : MultiTapeTM k Bool S₂) : MultiTapeTM k Bool (Option (S₁ ⊕ S₂)) := + armed (fun _inp work => if work i = some x then Sum.inl tm₁.q₀ else Sum.inr tm₂.q₀) tm₁ tm₂ + +variable {i : Fin k} {x : Bool} + +/-- The dispatch step when the symbol under tape `i` is `some x`: it lands on `tm₁`'s initial +configuration, embedded on the left. -/ +private lemma step_start_left (ws : Fin k → List Bool) (out : List Bool) + (h : (ws i).head? = some x) : + (branch i x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + leftCfg (S₂ := S₂) (wordsCfg input (some tm₁.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [branch, armed, Cfg.workTapeSymbols, tapeOfList_zero, h, leftCfg, Cfg.mapState, wordsCfg, + Action.apply, SignType.cast] + +/-- The dispatch step when the symbol under tape `i` is not `some x`: it lands on `tm₂`'s initial +configuration, embedded on the right. -/ +private lemma step_start_right (ws : Fin k → List Bool) (out : List Bool) + (h : ¬ (ws i).head? = some x) : + (branch i x tm₁ tm₂).step (wordsCfg input (some none) ws out) = + rightCfg (S₁ := S₁) (wordsCfg input (some tm₂.q₀) ws out) := by + have hstate : (wordsCfg (State := Option (S₁ ⊕ S₂)) input (some none) ws out).state = + some none := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [branch, armed, Cfg.workTapeSymbols, tapeOfList_zero, h, rightCfg, Cfg.mapState, wordsCfg, + Action.apply, SignType.cast] + +end Branch + +open Branch in +/-- **Branching on a tape symbol.** Given two transformations that share a postcondition `Q`, a +single machine reads the symbol under the head of work tape `i`: if it is `some x` it performs the +first transformation, otherwise the second. The dispatch costs one step and, moving no head, at +most `k` cells, so the time bound is `max t₁ t₂ + 1` and the space bound `max s₁ s₂ + k`. -/ +public theorem exists_transformsTapes_branch {J : Type*} {k : ℕ} (i : Fin k) (x : Bool) + {State₁ State₂ : Type} [Finite State₁] [Finite State₂] + {tm₁ : MultiTapeTM k Bool State₁} {tm₂ : MultiTapeTM k Bool State₂} + {P₁ P₂ : J → (input : List Bool) → (Fin k → List Bool) → Prop} + {Q : J → (input : List Bool) → (Fin k → List Bool) → (Fin k → List Bool) → Prop} + {t₁ s₁ t₂ s₂ : J → ℕ} + (h₁ : ∀ j, TransformsTapes tm₁ (P₁ j) (Q j) (t₁ j) (s₁ j)) + (h₂ : ∀ j, TransformsTapes tm₂ (P₂ j) (Q j) (t₂ j) (s₂ j)) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Bool State), ∀ j : J, + TransformsTapes tm + (fun input ws => if (ws i).head? = some x then P₁ j input ws else P₂ j input ws) + (Q j) (max (t₁ j) (t₂ j) + 1) (max (s₁ j) (s₂ j) + k) := by + refine ⟨Option (State₁ ⊕ State₂), inferInstance, branch i x tm₁ tm₂, fun j input ws out hP => ?_⟩ + -- the machine's initial state is the dispatch state `none` + rw [show (branch i x tm₁ tm₂).q₀ = none from rfl] + by_cases h : (ws i).head? = some x + · -- read `some x`: run `tm₁` + simp only [h] at hP + obtain ⟨τ₁, hτ₁, ws', hrun₁, hQ₁, hsp₁⟩ := h₁ j input ws out hP + have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + leftCfg (S₂ := State₂) (wordsCfg input (some tm₁.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_left ws out h] + refine ⟨τ₁ + 1, by have := Nat.le_max_left (t₁ j) (t₂ j); omega, ws', ?_, hQ₁, ?_⟩ + · rw [runFrom_succ_eq_step, step_start_left ws out h, runFrom_leftCfg, hrun₁] + simp + · -- space: the dispatch adds at most `k` cells, `tm₁`'s run at most `s₁ j` + have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 + fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₁ ≤ s₁ j := by + rw [hstep1] + refine le_trans (le_of_eq + (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₁) + (leftCfg (wordsCfg input (some tm₁.q₀) ws out)) (wordsCfg input (some tm₁.q₀) ws out) + τ₁ fun m _ => ?_)) hsp₁ + rw [runFrom_leftCfg, workTapePos_leftCfg] + calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ₁ + 1) + = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ₁) := by + rw [Nat.add_comm] + _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₁ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ₁ + _ ≤ k + s₁ j := Nat.add_le_add hsp1 hsp2 + _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_left (s₁ j) (s₂ j); omega + · -- read something else: run `tm₂` + simp only [h] at hP + obtain ⟨τ₂, hτ₂, ws', hrun₂, hQ₂, hsp₂⟩ := h₂ j input ws out hP + have hstep1 : (branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1 = + rightCfg (S₁ := State₁) (wordsCfg input (some tm₂.q₀) ws out) := by + rw [show (1 : ℕ) = 0 + 1 from rfl, runFrom_succ_eq_step', runFrom_zero, + step_start_right ws out h] + refine ⟨τ₂ + 1, by have := Nat.le_max_right (t₁ j) (t₂ j); omega, ws', ?_, hQ₂, ?_⟩ + · rw [runFrom_succ_eq_step, step_start_right ws out h, runFrom_rightCfg, hrun₂] + simp + · have hsp1 : (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 ≤ k := by + refine spaceUsed_le_of_workTapePos_const (wordsCfg input (some none) ws out) 1 + fun m _ => ?_ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hstep1]; rfl + have hsp2 : (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₂ ≤ s₂ j := by + rw [hstep1] + refine le_trans (le_of_eq + (spaceUsed_eq_of_workTapePos (tm := branch i x tm₁ tm₂) (tm' := tm₂) + (rightCfg (wordsCfg input (some tm₂.q₀) ws out)) (wordsCfg input (some tm₂.q₀) ws out) + τ₂ fun m _ => ?_)) hsp₂ + rw [runFrom_rightCfg, workTapePos_rightCfg] + calc (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (τ₂ + 1) + = (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) (1 + τ₂) := by + rw [Nat.add_comm] + _ ≤ (branch i x tm₁ tm₂).spaceUsed (wordsCfg input (some none) ws out) 1 + + (branch i x tm₁ tm₂).spaceUsed + ((branch i x tm₁ tm₂).runFrom (wordsCfg input (some none) ws out) 1) τ₂ := + spaceUsed_add_le (wordsCfg input (some none) ws out) 1 τ₂ + _ ≤ k + s₂ j := Nat.add_le_add hsp1 hsp2 + _ ≤ max (s₁ j) (s₂ j) + k := by have := Nat.le_max_right (s₁ j) (s₂ j); omega + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean new file mode 100644 index 0000000000..18be715b50 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Clear.lean @@ -0,0 +1,339 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# A machine that clears a work tape + +A two-state machine that erases the word on one designated work tape `i` and returns the head to +the start; every other tape is never written and its head never moves. In its first state the +machine scans right over the word until it reads the first blank, one cell past the word. In its +second state it sweeps back left, blanking every cell it reads. On the way down the cells to the +left of the head still hold their symbols, so the first blank read while sweeping is the cell at +position `-1`; the halting transition moves the head right, back to position `0`. + +On a word of length `L` the run takes `2 * L + 2` steps and visits the cells `-1, …, L` of tape +`i` and only the cell `0` of every other tape, so the machine runs in time `3 * (L + 1)` and space +`L + 1 + k`. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_clear`: the machine that replaces the word on tape + `i` by the empty word and leaves every other tape unchanged. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol : Type*} {input : List Symbol} + +/-- The clearing machine for tape `i`. In state `false` it scans right over the word on tape `i`; +on the first blank it turns around into state `true`. In state `true` it sweeps left, blanking +every cell it reads; on the first blank — the cell at position `-1` — it moves right and halts. +No other tape is ever written or moved, and the input head never moves. -/ +def clearTape (i : Fin k) : MultiTapeTM k Symbol Bool where + q₀ := false + tr q _ work := + match q, work i with + | false, some _ => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := none, state := some false } + | false, none => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some true } + | true, some _ => + { inputTape := 0, + workTapes := fun l => (if l = i then some none else none, if l = i then -1 else 0), + output := none, state := some true } + | true, none => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := none, state := none } + +namespace Clear + +variable {i : Fin k} {w : List Symbol} {ws : Fin k → List Symbol} {out : List Symbol} + {T : ℤ → Option Symbol} {p : ℤ} + +/-- A configuration of the clearing machine: state `q`, tape `i` holding `T` with its head at `p`, +every other tape `l` holding the word `ws l` with its head at `0`, the input head at the start and +output `out`. -/ +def cfg (input : List Symbol) (i : Fin k) (q : Option Bool) (T : ℤ → Option Symbol) (p : ℤ) + (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol Bool input := + ⟨q, 1, fun l => if l = i then T else tapeOfList (ws l), fun l => if l = i then p else 0, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as the tape-`i` contents and head position +agree. -/ +lemma cfg_congr {q : Option Bool} {T T' : ℤ → Option Symbol} {p p' : ℤ} (hT : T = T') + (hp : p = p') : cfg input i q T p ws out = cfg input i q T' p' ws out := by + rw [hT, hp] + +/-- The head of tape `i` is at `p`. -/ +lemma cfg_workTapePos_self (q : Option Bool) : + (cfg input i q T p ws out).workTapePos i = p := by + simp [cfg] + +/-- The head of every other tape is at `0`. -/ +lemma cfg_workTapePos_ne {l : Fin k} (h : l ≠ i) (q : Option Bool) : + (cfg input i q T p ws out).workTapePos l = 0 := by + simp [cfg, h] + +/-- A word configuration is a `cfg` whose tape `i` holds the word `ws i`. -/ +lemma wordsCfg_eq_cfg (q : Option Bool) (hws : ws i = w) : + wordsCfg input q ws out = cfg input i q (tapeOfList w) 0 ws out := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases eq_or_ne l i with rfl | h + · simp [wordsCfg, cfg, hws] + · simp [wordsCfg, cfg, h] + · funext l + simp [wordsCfg, cfg] + +/-- The halting `cfg` with a blank tape `i` is the word configuration in which the word on tape +`i` has been replaced by the empty word. -/ +lemma cfg_halt_eq_wordsCfg : + cfg input i none (fun _ => none) 0 ws out = + wordsCfg input none (Function.update ws i []) out := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l + rcases eq_or_ne l i with rfl | h + · simp [wordsCfg, cfg] + · simp [wordsCfg, cfg, h] + · funext l + simp [wordsCfg, cfg] + +/-- Scanning right in state `false`: over a symbol the head moves right and nothing is written. -/ +lemma step_scan {s : Symbol} (hT : T p = some s) : + (clearTape i).step (cfg input i (some false) T p ws out) = + cfg input i (some false) T (p + 1) ws out := by + have hsym : (cfg input i (some false) T p ws out).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- Turning around: on the blank one cell past the word, state `false` moves left and enters +state `true`. -/ +lemma step_turn (hT : T p = none) : + (clearTape i).step (cfg input i (some false) T p ws out) = + cfg input i (some true) T (p - 1) ws out := by + have hsym : (cfg input i (some false) T p ws out).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Sweeping left in state `true`: over a symbol the cell is blanked and the head moves left. -/ +lemma step_sweep {s : Symbol} (hT : T p = some s) : + (clearTape i).step (cfg input i (some true) T p ws out) = + cfg input i (some true) (Function.update T p none) (p - 1) ws out := by + have hsym : (cfg input i (some true) T p ws out).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Halting: on the blank at position `-1`, state `true` moves right and halts. -/ +lemma step_halt (hT : T p = none) : + (clearTape i).step (cfg input i (some true) T p ws out) = + cfg input i none T (p + 1) ws out := by + have hsym : (cfg input i (some true) T p ws out).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hT] + unfold step + simp only [cfg] at hsym ⊢ + simp only [clearTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- Blanking the cell just past the end of a word shortens the word by one symbol. -/ +lemma update_tapeOfList_eq_tapeOfList_take (w : List Symbol) (p : ℕ) : + Function.update (tapeOfList (w.take (p + 1))) (p : ℤ) none = tapeOfList (w.take p) := by + funext z + rcases eq_or_ne z (p : ℤ) with rfl | hz + · rw [Function.update_self, tapeOfList_ofNat] + exact (List.getElem?_eq_none (by simp)).symm + · rw [Function.update_of_ne hz] + cases z with + | negSucc n => simp + | ofNat n => + change (w.take (p + 1))[n]? = (w.take p)[n]? + have hn : n ≠ p := by rintro rfl; exact hz rfl + rcases Nat.lt_or_ge n p with h | h + · rw [List.getElem?_take_of_lt (by omega), List.getElem?_take_of_lt h] + · have h' : p < n := by omega + rw [List.getElem?_eq_none (by simp; omega), List.getElem?_eq_none (by simp; omega)] + +/-- After `n ≤ w.length` steps the machine is still scanning: the tape holds `w` untouched and +the head is at position `n`. -/ +lemma runFrom_scan (w : List Symbol) (n : ℕ) (hn : n ≤ w.length) : + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) n = + cfg input i (some false) (tapeOfList w) n ws out := by + induction n with + | zero => simp + | succ n ih => + have hsym : tapeOfList w (n : ℤ) = some (w[n]'(by omega)) := by + rw [tapeOfList_ofNat] + exact List.getElem?_eq_getElem (by omega) + rw [runFrom_succ_eq_step', ih (by omega), step_scan hsym] + exact cfg_congr rfl (by omega) + +/-- After `w.length + 1 + m` steps, for `m ≤ w.length`, the machine is sweeping: the last `m` +cells of the word have been blanked and the head is at position `w.length - 1 - m`. -/ +lemma runFrom_sweep (w : List Symbol) (m : ℕ) (hm : m ≤ w.length) : + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) + (w.length + 1 + m) = + cfg input i (some true) (tapeOfList (w.take (w.length - m))) + ((w.length : ℤ) - 1 - m) ws out := by + induction m with + | zero => + have hsym : tapeOfList w ((w.length : ℕ) : ℤ) = none := by simp + rw [Nat.add_zero, runFrom_succ_eq_step', runFrom_scan w w.length le_rfl, step_turn hsym] + exact cfg_congr (by simp) (by omega) + | succ m ih => + have hidx : (w.length : ℤ) - 1 - m = ((w.length - 1 - m : ℕ) : ℤ) := by omega + have hsym : tapeOfList (w.take (w.length - m)) ((w.length - 1 - m : ℕ) : ℤ) = + some (w[w.length - 1 - m]'(by omega)) := by + rw [tapeOfList_ofNat, List.getElem?_take_of_lt (by omega)] + exact List.getElem?_eq_getElem (by omega) + rw [show w.length + 1 + (m + 1) = w.length + 1 + m + 1 from rfl, runFrom_succ_eq_step', + ih (by omega), hidx, step_sweep hsym] + refine cfg_congr ?_ (by omega) + rw [show w.length - m = (w.length - 1 - m) + 1 from by omega, + update_tapeOfList_eq_tapeOfList_take, + show w.length - 1 - m = w.length - (m + 1) from by omega] + +/-- The complete run: after `2 * w.length + 2` steps the machine has halted with tape `i` blank +and its head back at `0`. -/ +lemma runFrom_full (w : List Symbol) : + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) + (2 * w.length + 2) = + cfg input i none (fun _ => none) 0 ws out := by + rw [show 2 * w.length + 2 = w.length + 1 + w.length + 1 from by omega, runFrom_succ_eq_step', + runFrom_sweep w w.length le_rfl, step_halt (by simp)] + exact cfg_congr (by simp) (by omega) + +/-- At every step of the run the configuration has the shape `cfg`, with the head of tape `i` +between the positions `-1` and `w.length`. -/ +lemma runFrom_shape (w : List Symbol) (t : ℕ) (ht : t ≤ 2 * w.length + 2) : + ∃ (q : Option Bool) (T : ℤ → Option Symbol) (p : ℤ), -1 ≤ p ∧ p ≤ w.length ∧ + (clearTape i).runFrom (cfg input i (some false) (tapeOfList w) 0 ws out) t = + cfg input i q T p ws out := by + by_cases h : t ≤ w.length + · exact ⟨some false, tapeOfList w, t, by omega, by omega, runFrom_scan w t h⟩ + by_cases h2 : t ≤ 2 * w.length + 1 + · obtain ⟨m, hm, rfl⟩ : ∃ m, m ≤ w.length ∧ t = w.length + 1 + m := + ⟨t - (w.length + 1), by omega, by omega⟩ + exact ⟨some true, tapeOfList (w.take (w.length - m)), (w.length : ℤ) - 1 - m, by omega, + by omega, runFrom_sweep w m hm⟩ + rw [show t = 2 * w.length + 2 from by omega] + exact ⟨none, fun _ => none, 0, by omega, by omega, runFrom_full w⟩ + +/-- The run visits the cells `-1, …, w.length` of tape `i` and only the cell `0` of every other +tape, so it uses at most `w.length + 1 + k` cells in total. -/ +lemma spaceUsed_le (w : List Symbol) : + (clearTape i).spaceUsed (cfg input i (some false) (tapeOfList w) 0 ws out) + (2 * w.length + 2) ≤ w.length + 1 + k := by + set c₀ := cfg input i (some false) (tapeOfList w) 0 ws out + set τ := 2 * w.length + 2 + have hi : (clearTape i).spaceUsedByTape c₀ τ i ≤ w.length + 2 := by + have hsub : (clearTape i).visitedByTapeHead c₀ τ i ⊆ + Finset.Icc (-1 : ℤ) (w.length : ℤ) := by + intro z hz + obtain ⟨t, ht, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q, T, p, hp₁, hp₂, heq⟩ := runFrom_shape w t (by omega) + rw [heq, cfg_workTapePos_self] + exact Finset.mem_Icc.mpr ⟨hp₁, hp₂⟩ + refine (Finset.card_le_card hsub).trans_eq ?_ + rw [Int.card_Icc] + omega + have hne : ∀ l, l ≠ i → (clearTape i).spaceUsedByTape c₀ τ l ≤ 1 := by + intro l hl + have hsub : (clearTape i).visitedByTapeHead c₀ τ l ⊆ {0} := by + intro z hz + obtain ⟨t, ht, rfl⟩ := mem_visitedByTapeHead.mp hz + obtain ⟨q, T, p, _, _, heq⟩ := runFrom_shape w t (by omega) + rw [heq, cfg_workTapePos_ne hl] + simp + exact (Finset.card_le_card hsub).trans_eq (Finset.card_singleton 0) + have hsplit : (clearTape i).spaceUsed c₀ τ = (clearTape i).spaceUsedByTape c₀ τ i + + ∑ l ∈ Finset.univ.erase i, (clearTape i).spaceUsedByTape c₀ τ l := + (Finset.add_sum_erase Finset.univ _ (Finset.mem_univ i)).symm + have hsum : ∑ l ∈ Finset.univ.erase i, (clearTape i).spaceUsedByTape c₀ τ l ≤ k - 1 := by + have := Finset.sum_le_card_nsmul (Finset.univ.erase i) + (fun l => (clearTape i).spaceUsedByTape c₀ τ l) 1 + (fun l hl => hne l (Finset.mem_erase.mp hl).1) + simpa [Finset.card_erase_of_mem] using this + have hk : 0 < k := i.pos + omega + +end Clear + +/-- **The machine that clears a work tape.** One machine per tape index `i` (uniform over the +words `w`): it replaces the word on tape `i` by the empty word and leaves every other tape +unchanged, in at most `3 * (w.length + 1)` steps and `w.length + 1 + k` cells. -/ +public theorem exists_transformsTapes_clear {Symbol : Type*} {k : ℕ} (i : Fin k) : + ∃ (c : ℕ) (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), + ∀ w : List Symbol, + TransformsTapes tm (fun _ ws => ws i = w) + (fun _ ws ws' => ws' = Function.update ws i []) + (c * (w.length + 1)) (w.length + 1 + k) := by + refine ⟨3, Bool, inferInstance, clearTape i, fun w input ws out hws => ?_⟩ + have hstart : wordsCfg input (some (clearTape i : MultiTapeTM k Symbol Bool).q₀) ws out = + Clear.cfg input i (some false) (tapeOfList w) 0 ws out := + Clear.wordsCfg_eq_cfg _ hws + refine ⟨2 * w.length + 2, by omega, Function.update ws i [], ?_, rfl, ?_⟩ + · rw [hstart, Clear.runFrom_full, Clear.cfg_halt_eq_wordsCfg] + · rw [hstart] + exact Clear.spaceUsed_le w + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean new file mode 100644 index 0000000000..29f3dfcce2 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/EmitTape.lean @@ -0,0 +1,502 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas + +/-! +# Machines that emit a work tape to the output and set a single cell + +Two small machines used by combinators to assemble the write-only output tape and to place or +remove markers on a work tape. + +`emitTape i` reads the word held on work tape `i` from its start and appends it, symbol by symbol, +to the real output tape, moving the tape-`i` head right over the word and halting on the first +blank. It never writes to any work tape, never moves the input head and never moves any other work +head: the only lasting effect is the appended output and the tape-`i` head resting at the frontier +`w.length`. + +`setCell i v` writes a designated symbol value `v` into cell `-1` of work tape `i` — the cell just +left of the word — and returns the head to `0`, touching nothing else. It is the primitive used to +place or clear a flag mark. The machine is specialised to the cell `-1`, the only cell the callers +need; a general version for an arbitrary cell `z` would require a head able to reach `z`, i.e. a +state count depending on `z`. + +## Main results + +* `Turing.MultiTapeTM.exists_emitTape`: the machine appending a work tape's word to the output. +* `Turing.MultiTapeTM.exists_setCell`: the machine setting cell `-1` of a work tape to a value. +-/ + +namespace Turing.MultiTapeTM + +variable {K : ℕ} {Symbol : Type*} {input : List Symbol} + +/-! ## Emitting a work tape to the output -/ + +/-- The tape-emitting machine for tape `i`. It has a single live state. Reading a symbol `s` on +tape `i` it appends `s` to the output, moves the tape-`i` head right and stays live; reading the +first blank it halts, writing nothing and moving nothing. No work tape is ever written, the input +head never moves and no other work head moves. -/ +def emitTape (i : Fin K) : MultiTapeTM K Symbol Unit where + q₀ := () + tr _ _ work := + match work i with + | some s => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := some s, state := some () } + | none => + { inputTape := 0, workTapes := fun _ => (none, 0), + output := none, state := none } + +namespace EmitTape + +variable {i : Fin K} {ip : Fin (input.length + 2)} {W : Fin K → ℤ → Option Symbol} + {WP : Fin K → ℤ} {out : List Symbol} {p : ℤ} + +/-- A configuration of the emitting machine: state `q`, the head of tape `i` at `p`, tape contents +`W`, the other heads `WP`, the input head `ip` and output `out`. -/ +def cfg (input : List Symbol) (i : Fin K) (q : Option Unit) + (ip : Fin (input.length + 2)) (W : Fin K → ℤ → Option Symbol) (WP : Fin K → ℤ) + (out : List Symbol) (p : ℤ) : Cfg K Symbol Unit input := + ⟨q, ip, W, Function.update WP i p, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as their outputs and tape-`i` head +positions agree. -/ +lemma cfg_congr {q : Option Unit} {out out' : List Symbol} {p p' : ℤ} + (hout : out = out') (hp : p = p') : + cfg input i q ip W WP out p = cfg input i q ip W WP out' p' := by + rw [hout, hp] + +/-- Emitting one symbol: reading `s` on tape `i` appends `s` to the output and moves the head +right, staying live. -/ +lemma step_emit_some {s : Symbol} (hs : W i p = some s) : + (emitTape i).step (cfg input i (some ()) ip W WP out p) = + cfg input i (some ()) ip W WP (out ++ [s]) (p + 1) := by + have hsym : (cfg input i (some ()) ip W WP out p).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [emitTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- Halting: reading the first blank on tape `i` the machine halts, writing and moving nothing. -/ +lemma step_emit_none (hs : W i p = none) : + (emitTape i).step (cfg input i (some ()) ip W WP out p) = + cfg input i none ip W WP out p := by + have hsym : (cfg input i (some ()) ip W WP out p).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [emitTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- The scanning phase: from the start of the word, after `n ≤ w.length` steps the head is at +position `n` and the first `n` symbols of `w` have been appended to the output. -/ +lemma runFrom_scan {w : List Symbol} (hw : W i = tapeOfList w) (n : ℕ) (hn : n ≤ w.length) : + (emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) n = + cfg input i (some ()) ip W WP (out ++ w.take n) (n : ℤ) := by + induction n with + | zero => + rw [runFrom_zero] + exact cfg_congr (by simp) (by simp) + | succ n ih => + have hsym : W i (n : ℤ) = some (w[n]'(by omega)) := by + rw [hw, tapeOfList_ofNat] + exact List.getElem?_eq_getElem (by omega) + rw [runFrom_succ_eq_step', ih (by omega), step_emit_some hsym] + refine cfg_congr ?_ (by push_cast; omega) + rw [List.append_assoc, List.take_concat_get' w n (by omega)] + +/-- The complete run: from the start of the word, after `w.length + 1` steps the machine has +halted with the full word `w` appended to the output and the head at the frontier `w.length`. -/ +lemma runFrom_full {w : List Symbol} (hw : W i = tapeOfList w) : + (emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) (w.length + 1) = + cfg input i none ip W WP (out ++ w) (w.length : ℤ) := by + have hnone : W i (w.length : ℤ) = none := by + rw [hw, tapeOfList_ofNat] + exact List.getElem?_eq_none (by omega) + rw [runFrom_succ_eq_step', runFrom_scan hw w.length le_rfl, step_emit_none hnone] + exact cfg_congr (by rw [List.take_length]) rfl + +/-- Throughout the run the head of tape `i` stays within `[0, w.length]`: it walks right from the +start of the word to the frontier and stops. -/ +lemma runFrom_pos_range {w : List Symbol} (hw : W i = tapeOfList w) (m : ℕ) + (hm : m ≤ w.length + 1) : + (0 : ℤ) ≤ ((emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) m).workTapePos i ∧ + ((emitTape i).runFrom (cfg input i (some ()) ip W WP out 0) m).workTapePos i ≤ + (w.length : ℤ) := by + rcases Nat.lt_or_ge m (w.length + 1) with hlt | hge + · have hml : m ≤ w.length := by omega + rw [runFrom_scan hw m hml] + constructor <;> simp only [cfg, Function.update_self] <;> omega + · obtain rfl : m = w.length + 1 := by omega + rw [runFrom_full hw] + constructor <;> simp only [cfg, Function.update_self] <;> omega + +/-- No action of the machine writes to a work tape. -/ +lemma tr_write_none (q : Unit) (inp : Option Symbol) (work : Fin K → Option Symbol) (l : Fin K) : + (((emitTape i).tr q inp work).workTapes l).1 = none := by + simp only [emitTape] + cases work i <;> rfl + +/-- No action of the machine moves the input head. -/ +lemma tr_inputTape (q : Unit) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((emitTape i).tr q inp work).inputTape = 0 := by + simp only [emitTape] + cases work i <;> rfl + +/-- No action of the machine moves a work head other than the head of tape `i`. -/ +lemma tr_move_ne (q : Unit) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((emitTape i).tr q inp work).workTapes l).2 = 0 := by + simp only [emitTape] + cases work i <;> simp [h] + +/-- One step preserves the input head, every tape's contents and every work head other than the +head of tape `i`. (The output does change.) -/ +lemma step_frame (c : Cfg K Symbol Unit input) : + ((emitTape i).step c).inputPos = c.inputPos ∧ + (∀ j, ((emitTape i).step c).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((emitTape i).step c).workTapePos j = c.workTapePos j) := by + cases hc : c.state with + | none => rw [step_of_halt hc]; exact ⟨rfl, fun _ => rfl, fun _ _ => rfl⟩ + | some q => + refine ⟨?_, ?_, ?_⟩ + · rw [step_inputPos_of_state hc, tr_inputTape, moveInputPos_zero] + · intro j + rw [step_workTapes_of_state hc, tr_write_none q c.inputSymbol c.workTapeSymbols j] + · intro j hj + rw [step_workTapePos_of_state hc, tr_move_ne q c.inputSymbol c.workTapeSymbols hj] + simp + +/-- The whole run preserves the input head, every tape's contents and every work head other than +the head of tape `i`. -/ +lemma runFrom_frame (c : Cfg K Symbol Unit input) (m : ℕ) : + ((emitTape i).runFrom c m).inputPos = c.inputPos ∧ + (∀ j, ((emitTape i).runFrom c m).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((emitTape i).runFrom c m).workTapePos j = c.workTapePos j) := by + induction m with + | zero => exact ⟨rfl, fun _ => rfl, fun _ _ => rfl⟩ + | succ m ih => + obtain ⟨h1, h2, h3⟩ := step_frame ((emitTape i).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, fun j => (h2 j).trans (ih.2.1 j), + fun j hj => (h3 j hj).trans (ih.2.2 j hj)⟩ + +end EmitTape + +open EmitTape in +/-- **The machine that appends a work tape's word to the output.** One machine per tape index `i`: +started with tape `i` holding a word `w` in cells `0, …, w.length - 1` and the head at position +`0`, it halts within `w.length + 2` steps having appended `w` to the output, with the tape-`i` +head resting at the frontier `w.length` and every other field — input head, all tape contents and +all other work heads — unchanged at every step of the run. Before the halting step the machine is +live, so runs chain sequentially. -/ +public theorem exists_emitTape {Symbol : Type*} {K : ℕ} (i : Fin K) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Symbol State), + ∀ (input : List Symbol) (c : Cfg K Symbol State input) (w : List Symbol), + c.state = some tm.q₀ → + c.workTapes i = tapeOfList w → + c.workTapePos i = 0 → + ∃ u ≤ w.length + 2, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, c.workTapes, + Function.update c.workTapePos i (w.length : ℤ), c.output ++ w⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).inputPos = c.inputPos ∧ + (∀ j, (tm.runFrom c m).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → (tm.runFrom c m).workTapePos j = c.workTapePos j) ∧ + (0 : ℤ) ≤ (tm.runFrom c m).workTapePos i ∧ + (tm.runFrom c m).workTapePos i ≤ (w.length : ℤ) := by + refine ⟨Unit, inferInstance, emitTape i, fun input c w hstate hwi hwp => ?_⟩ + obtain ⟨q, ip, W, WP, out⟩ := c + obtain rfl : q = some () := hstate + have hwi' : W i = tapeOfList w := hwi + have hwp' : WP i = 0 := hwp + have hc0 : (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) = + cfg input i (some ()) ip W WP out 0 := by + refine Cfg.ext rfl rfl rfl ?_ rfl + change WP = Function.update WP i 0 + rw [← hwp', Function.update_eq_self] + obtain ⟨u, hu, hactive, hhalt⟩ : ∃ u ≤ w.length + 1, + (∀ m < u, ((emitTape i).runFrom + (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) m).state ≠ none) ∧ + (emitTape i).runFrom (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) u = + ⟨none, ip, W, Function.update WP i (w.length : ℤ), out ++ w⟩ := by + have hrun : (emitTape i).runFrom + (⟨some (), ip, W, WP, out⟩ : Cfg K Symbol Unit input) (w.length + 1) = + ⟨none, ip, W, Function.update WP i (w.length : ℤ), out ++ w⟩ := by + rw [hc0, runFrom_full hwi'] + simp only [cfg] + obtain ⟨u, hu, hhaltu, hact⟩ := + exists_minimal_halting_time (emitTape i) _ (w.length + 1) (by rw [hrun]) + have heq := runFrom_eq_of_halt (emitTape i) _ hu hhaltu + rw [hrun] at heq + exact ⟨u, hu, hact, heq.symm⟩ + refine ⟨u, by omega, hactive, hhalt, fun m hm => ?_⟩ + obtain ⟨f1, f2, f3⟩ := runFrom_frame (⟨some (), ip, W, WP, out⟩) m + obtain ⟨g1, g2⟩ := runFrom_pos_range (input := input) (i := i) (ip := ip) (W := W) (WP := WP) + (out := out) hwi' m (by omega) + rw [← hc0] at g1 g2 + exact ⟨f1, f2, f3, g1, g2⟩ + +/-! ## Setting a single work-tape cell -/ + +/-- The control states of the cell-setting machine: `go` walks the head one cell left to cell +`-1`, `write` writes the value there and returns the head to `0`. -/ +inductive SetCellState : Type + | go + | write + +instance : Finite SetCellState := + Finite.of_injective + (fun q => match q with + | .go => (0 : Fin 2) + | .write => 1) + (fun a b h => by cases a <;> cases b <;> first | rfl | exact absurd h (by decide)) + +/-- The cell-setting machine for tape `i` and value `v`. In state `go` it moves the head of tape +`i` one cell left, into state `write`. In state `write` it writes `v` at the current cell, moves +the head right and halts. No other tape is ever written, the input head never moves, no other work +head moves and nothing is output. -/ +def setCell (i : Fin K) (v : Option Symbol) : MultiTapeTM K Symbol SetCellState where + q₀ := .go + tr q _ _ := + match q with + | .go => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some .write } + | .write => + { inputTape := 0, + workTapes := fun l => (if l = i then some v else none, if l = i then 1 else 0), + output := none, state := none } + +namespace SetCell + +variable {i : Fin K} {v : Option Symbol} {ip : Fin (input.length + 2)} + {W : Fin K → ℤ → Option Symbol} {WP : Fin K → ℤ} {out : List Symbol} {p : ℤ} + +/-- A configuration of the cell-setting machine: state `q`, tape contents `W`, the head of tape +`i` at `p`, the other heads `WP`, the input head `ip` and output `out`. -/ +def cfg (input : List Symbol) (i : Fin K) (q : Option SetCellState) + (ip : Fin (input.length + 2)) (W : Fin K → ℤ → Option Symbol) (WP : Fin K → ℤ) + (out : List Symbol) (p : ℤ) : Cfg K Symbol SetCellState input := + ⟨q, ip, W, Function.update WP i p, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as their tape contents and tape-`i` head +positions agree. -/ +lemma cfg_congr {q : Option SetCellState} {W W' : Fin K → ℤ → Option Symbol} {p p' : ℤ} + (hW : W = W') (hp : p = p') : + cfg input i q ip W WP out p = cfg input i q ip W' WP out p' := by + rw [hW, hp] + +/-- Moving the head of tape `i` left in state `go`, unconditionally, entering `write`. -/ +lemma step_go : + (setCell i v).step (cfg input i (some .go) ip W WP out p) = + cfg input i (some .write) ip W WP out (p - 1) := by + unfold step + simp only [cfg] + simp only [setCell] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Writing `v` at the current cell in state `write`, moving the head right and halting. -/ +lemma step_write : + (setCell i v).step (cfg input i (some .write) ip W WP out p) = + cfg input i none ip (Function.update W i (Function.update (W i) p v)) WP out (p + 1) := by + unfold step + simp only [cfg] + simp only [setCell] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- After one step the machine is in state `write` with the head at cell `-1`. -/ +lemma runFrom_one : + (setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) 1 = + cfg input i (some .write) ip W WP out (-1) := by + rw [runFrom_succ_eq_step', runFrom_zero, step_go] + exact cfg_congr rfl (by omega) + +/-- The complete run: after two steps the machine has written `v` at cell `-1` of tape `i` and +returned the head to `0`. -/ +lemma runFrom_two : + (setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) 2 = + cfg input i none ip (Function.update W i (Function.update (W i) (-1) v)) WP out 0 := by + rw [show (2 : ℕ) = 1 + 1 from rfl, runFrom_add, runFrom_one, runFrom_succ_eq_step', + runFrom_zero, step_write] + exact cfg_congr rfl (by omega) + +/-- Throughout the run the head of tape `i` stays within `[-1, 0]`. -/ +lemma runFrom_pos_range (m : ℕ) (hm : m ≤ 2) : + (-1 : ℤ) ≤ ((setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) m).workTapePos i ∧ + ((setCell i v).runFrom (cfg input i (some .go) ip W WP out 0) m).workTapePos i ≤ 0 := by + rcases m with _ | _ | _ | m + · rw [runFrom_zero] + constructor <;> simp only [cfg, Function.update_self] <;> omega + · rw [runFrom_one] + constructor <;> simp only [cfg, Function.update_self] <;> omega + · rw [runFrom_two] + constructor <;> simp only [cfg, Function.update_self] <;> omega + · exact absurd hm (by omega) + +/-- No action of the machine moves the input head. -/ +lemma tr_inputTape (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((setCell i v).tr q inp work).inputTape = 0 := by + simp only [setCell] + cases q <;> rfl + +/-- No action of the machine outputs. -/ +lemma tr_output (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((setCell i v).tr q inp work).output = none := by + simp only [setCell] + cases q <;> rfl + +/-- No action of the machine writes to a work tape other than tape `i`. -/ +lemma tr_write_ne (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((setCell i v).tr q inp work).workTapes l).1 = none := by + simp only [setCell] + cases q <;> simp [h] + +/-- No action of the machine moves a work head other than the head of tape `i`. -/ +lemma tr_move_ne (q : SetCellState) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((setCell i v).tr q inp work).workTapes l).2 = 0 := by + simp only [setCell] + cases q <;> simp [h] + +/-- One step preserves the input head, the output, and every tape's contents and work head other +than those of tape `i`. -/ +lemma step_frame (c : Cfg K Symbol SetCellState input) : + ((setCell i v).step c).inputPos = c.inputPos ∧ + ((setCell i v).step c).output = c.output ∧ + (∀ j, j ≠ i → ((setCell i v).step c).workTapes j = c.workTapes j ∧ + ((setCell i v).step c).workTapePos j = c.workTapePos j) := by + cases hc : c.state with + | none => rw [step_of_halt hc]; exact ⟨rfl, rfl, fun _ _ => ⟨rfl, rfl⟩⟩ + | some q => + refine ⟨?_, ?_, ?_⟩ + · rw [step_inputPos_of_state hc, tr_inputTape, moveInputPos_zero] + · rw [step_apply_of_state hc, Action.apply_output, tr_output]; simp + · intro j hj + refine ⟨?_, ?_⟩ + · rw [step_workTapes_of_state hc, tr_write_ne q c.inputSymbol c.workTapeSymbols hj] + · rw [step_workTapePos_of_state hc, tr_move_ne q c.inputSymbol c.workTapeSymbols hj]; simp + +/-- The whole run preserves the input head, the output, and every tape's contents and work head +other than those of tape `i`. -/ +lemma runFrom_frame (c : Cfg K Symbol SetCellState input) (m : ℕ) : + ((setCell i v).runFrom c m).inputPos = c.inputPos ∧ + ((setCell i v).runFrom c m).output = c.output ∧ + (∀ j, j ≠ i → ((setCell i v).runFrom c m).workTapes j = c.workTapes j ∧ + ((setCell i v).runFrom c m).workTapePos j = c.workTapePos j) := by + induction m with + | zero => exact ⟨rfl, rfl, fun _ _ => ⟨rfl, rfl⟩⟩ + | succ m ih => + obtain ⟨h1, h2, h3⟩ := step_frame ((setCell i v).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, h2.trans ih.2.1, + fun j hj => ⟨(h3 j hj).1.trans (ih.2.2 j hj).1, (h3 j hj).2.trans (ih.2.2 j hj).2⟩⟩ + +end SetCell + +open SetCell in +/-- **The machine that sets cell `-1` of a work tape.** One machine per tape index `i` and value +`v`: started with the head of tape `i` at position `0`, it halts within `4` steps having written +`v` into cell `-1` of tape `i` and returned the head to `0`, with every other field — input head, +output, all other tape contents and all other work heads — unchanged at every step of the run. +Before the halting step the machine is live, so runs chain sequentially. + +This is the specialisation to the cell `z = -1` of a general "set cell `z`" primitive: it is the +only cell the callers (which mark and clear the flag cell just left of a word) need, and the +excursion is confined to `[-1, 0]`. -/ +public theorem exists_setCell {Symbol : Type*} {K : ℕ} (i : Fin K) (v : Option Symbol) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Symbol State), + ∀ (input : List Symbol) (c : Cfg K Symbol State input), + c.state = some tm.q₀ → c.workTapePos i = 0 → + ∃ u ≤ 4, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, + Function.update c.workTapes i (Function.update (c.workTapes i) (-1) v), + c.workTapePos, c.output⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).inputPos = c.inputPos ∧ (tm.runFrom c m).output = c.output ∧ + (∀ j, j ≠ i → (tm.runFrom c m).workTapes j = c.workTapes j ∧ + (tm.runFrom c m).workTapePos j = c.workTapePos j) ∧ + (-1 : ℤ) ≤ (tm.runFrom c m).workTapePos i ∧ (tm.runFrom c m).workTapePos i ≤ 0 := by + refine ⟨SetCellState, inferInstance, setCell i v, fun input c hstate hwp => ?_⟩ + obtain ⟨q, ip, W, WP, out⟩ := c + obtain rfl : q = some SetCellState.go := hstate + have hwp' : WP i = 0 := hwp + have hupdWP : Function.update WP i 0 = WP := by rw [← hwp', Function.update_eq_self] + have hc0 : (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) = + cfg input i (some .go) ip W WP out 0 := by + refine Cfg.ext rfl rfl rfl ?_ rfl + exact hupdWP.symm + obtain ⟨u, hu, hactive, hhalt⟩ : ∃ u ≤ 2, + (∀ m < u, ((setCell i v).runFrom + (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) + m).state ≠ none) ∧ + (setCell i v).runFrom + (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) u = + ⟨none, ip, Function.update W i (Function.update (W i) (-1) v), WP, out⟩ := by + have hrun : (setCell i v).runFrom + (⟨some SetCellState.go, ip, W, WP, out⟩ : Cfg K Symbol SetCellState input) 2 = + ⟨none, ip, Function.update W i (Function.update (W i) (-1) v), WP, out⟩ := by + rw [hc0, runFrom_two] + unfold cfg + rw [hupdWP] + obtain ⟨u, hu, hhaltu, hact⟩ := + exists_minimal_halting_time (setCell i v) _ 2 (by rw [hrun]) + have heq := runFrom_eq_of_halt (setCell i v) _ hu hhaltu + rw [hrun] at heq + exact ⟨u, hu, hact, heq.symm⟩ + refine ⟨u, by omega, hactive, hhalt, fun m hm => ?_⟩ + obtain ⟨f1, f2, f3⟩ := runFrom_frame (⟨some SetCellState.go, ip, W, WP, out⟩) m + obtain ⟨g1, g2⟩ := runFrom_pos_range (input := input) (i := i) (v := v) (ip := ip) (W := W) + (WP := WP) (out := out) m (by omega) + rw [← hc0] at g1 g2 + exact ⟨f1, f2, f3, g1, g2⟩ + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean new file mode 100644 index 0000000000..0f4ac2e2be --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/ExtendTapes.lean @@ -0,0 +1,230 @@ +/- +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 Mathlib.Algebra.BigOperators.Fin +public import Mathlib.Data.Fintype.Inv +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas + +/-! +# Reindexing a machine's work tapes along an embedding + +`extendTapes tm e`, for an embedding `e : Fin k ↪ Fin k'`, runs `tm` inside a machine with `k'` +work tapes, using the tapes selected by `e`: work tape `e j` plays the role of `tm`'s tape `j`, +and every tape outside the range of `e` is never written and never moves. + +The construction is a step-semiconjugation. The configuration map `embed e cfg extraTapes extraPos` +places `cfg` on the tapes in the range of `e` and fills the others with fixed contents `extraTapes` +and head positions `extraPos`; `step` commutes with it unconditionally, so the reindexed run +mirrors the original by `Turing.MultiTapeTM.runFrom_comm_of_step` — no induction. Since the extra +tapes never move, the reindexed run uses the same space on the embedded tapes as `tm` does, plus at +most one cell for each of the remaining tapes. + +Both the machine and the configuration map route each target tape `l` through the computable +partial inverse `partialInv e l : Option (Fin k)`, which is `some j` exactly when `e j = l`. Since +they share this scrutinee, the semiconjugation splits tape by tape into a source tape (`some j`) or +an untouched extra tape (`none`). +-/ + +namespace Turing.MultiTapeTM + +variable {k k' : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- The computable partial inverse of the embedding `e`: `partialInv e l = some j` when `e j = l` +(such `j` is unique by injectivity), and `none` when `l` lies outside the range of `e`. -/ +@[expose] public def partialInv (e : Fin k ↪ Fin k') (l : Fin k') : Option (Fin k) := + if h : ∃ j, e j = l then + some (Fintype.choose (fun j => e j = l) + (existsUnique_of_exists_of_unique h fun _ _ ha hb => e.injective (ha.trans hb.symm))) + else none + +/-- `tm` run on the tapes selected by the embedding `e`, leaving other tapes untouched: work tape +`e j` plays the role of `tm`'s tape `j`, and any tape outside `range e` is never written and never +moves. -/ +@[expose] public def extendTapes (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') : + MultiTapeTM k' Symbol State where + q₀ := tm.q₀ + tr q inp work := + let a := tm.tr q inp fun j => work (e j) + { inputTape := a.inputTape + workTapes := fun l => match partialInv e l with + | some j => a.workTapes j + | none => (none, 0) + output := a.output + state := a.state } + +/-- A configuration of `tm`, embedded: tape `j` goes to tape `e j`, the tapes outside `range e` +carry the given `extraTapes` contents and `extraPos` head positions. -/ +@[expose] public def embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) : + Cfg k' Symbol State input := + ⟨cfg.state, cfg.inputPos, + fun l => match partialInv e l with + | some j => cfg.workTapes j + | none => extraTapes l, + fun l => match partialInv e l with + | some j => cfg.workTapePos j + | none => extraPos l, + cfg.output⟩ + +variable {tm : MultiTapeTM k Symbol State} {e : Fin k ↪ Fin k'} + {cfg : Cfg k Symbol State input} {extraTapes : Fin k' → ℤ → Option Symbol} {extraPos : Fin k' → ℤ} + +/-- The partial inverse recovers the source tape of an embedded tape. -/ +@[simp] +public lemma partialInv_embed (e : Fin k ↪ Fin k') (j : Fin k) : partialInv e (e j) = some j := by + have hex : ∃ j', e j' = e j := ⟨j, rfl⟩ + have hpi : partialInv e (e j) = some (Fintype.choose (fun j' => e j' = e j) + (existsUnique_of_exists_of_unique hex fun _ _ ha hb => e.injective (ha.trans hb.symm))) := + dite_eq_left hex + rw [hpi] + congr 1 + exact e.injective (Fintype.choose_spec (fun j' => e j' = e j) _) + +/-- Outside the range of `e`, the partial inverse is undefined. -/ +public lemma partialInv_eq_none (e : Fin k ↪ Fin k') {l : Fin k'} (hl : ¬ ∃ j, e j = l) : + partialInv e l = none := + dite_eq_right hl + +/-- If the partial inverse is `some j`, then `e j = l`. -/ +public lemma partialInv_eq_some (e : Fin k ↪ Fin k') {l : Fin k'} {j : Fin k} + (h : partialInv e l = some j) : e j = l := by + unfold partialInv at h + by_cases hl : ∃ j, e j = l + · rw [dite_eq_left hl] at h + have hspec := Fintype.choose_spec (fun j' => e j' = l) + (existsUnique_of_exists_of_unique hl fun _ _ ha hb => e.injective (ha.trans hb.symm)) + rw [Option.some_inj] at h + rw [← h]; exact hspec + · rw [dite_eq_right hl] at h; exact absurd h (by simp) + +@[simp] +public lemma embed_workTapes_embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) (j : Fin k) : + (embed e cfg extraTapes extraPos).workTapes (e j) = cfg.workTapes j := by + simp only [embed, partialInv_embed] + +@[simp] +public lemma embed_workTapePos_embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) (j : Fin k) : + (embed e cfg extraTapes extraPos).workTapePos (e j) = cfg.workTapePos j := by + simp only [embed, partialInv_embed] + +@[simp] +public lemma embed_workTapeSymbols_embed (e : Fin k ↪ Fin k') (cfg : Cfg k Symbol State input) + (extraTapes : Fin k' → ℤ → Option Symbol) (extraPos : Fin k' → ℤ) (j : Fin k) : + (embed e cfg extraTapes extraPos).workTapeSymbols (e j) = cfg.workTapeSymbols j := by + simp only [Cfg.workTapeSymbols, embed_workTapes_embed, embed_workTapePos_embed] + +/-- Reindexing is a step-semiconjugation: the reindexed machine acts on the embedded tapes exactly +as `tm` does, and never touches the extra tapes. -/ +public lemma step_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) : + (tm.extendTapes e).step (embed e cfg extraTapes extraPos) + = embed e (tm.step cfg) extraTapes extraPos := by + cases hq : cfg.state with + | none => + have h1 : (embed e cfg extraTapes extraPos).state = none := hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (embed e cfg extraTapes extraPos).state = some q := hq + have hin : (embed e cfg extraTapes extraPos).inputSymbol = cfg.inputSymbol := rfl + have hargs : (fun j : Fin k => (embed e cfg extraTapes extraPos).workTapeSymbols (e j)) + = cfg.workTapeSymbols := + funext fun j => embed_workTapeSymbols_embed e cfg extraTapes extraPos j + rw [step_apply_of_state h1, step_apply_of_state hq] + simp only [extendTapes, hin, hargs] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + simp only [Action.apply, embed] + cases partialInv e l <;> rfl + · funext l + simp only [Action.apply, embed] + cases partialInv e l <;> simp + +/-- The reindexed run mirrors the original, with the extra tapes held fixed throughout. -/ +public lemma runFrom_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) : + (tm.extendTapes e).runFrom (embed e cfg extraTapes extraPos) n + = embed e (tm.runFrom cfg n) extraTapes extraPos := + runFrom_comm_of_step (fun c => embed e c extraTapes extraPos) + (fun c => step_embed tm e c extraTapes extraPos) cfg n + +section Space + +/-- On an embedded tape `e j`, the reindexed run's head visits exactly the cells `tm`'s head of +tape `j` visits. -/ +public lemma visitedByTapeHead_embed_embed (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) (j : Fin k) : + (tm.extendTapes e).visitedByTapeHead (embed e cfg extraTapes extraPos) n (e j) + = tm.visitedByTapeHead cfg n j := by + refine Finset.image_congr fun m _ => ?_ + rw [runFrom_embed, embed_workTapePos_embed] + +/-- The head of a tape outside `range e` never leaves its starting position. -/ +public lemma workTapePos_embed_of_not_range (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) {l : Fin k'} (hl : ¬ ∃ j, e j = l) : + ((tm.extendTapes e).runFrom (embed e cfg extraTapes extraPos) n).workTapePos l + = extraPos l := by + rw [runFrom_embed] + simp only [embed, partialInv_eq_none e hl] + +/-- **Space bound for a reindexed run.** The embedded tapes use exactly the space `tm` uses; each +of the remaining `k' - k` tapes never moves, so it contributes at most one cell. -/ +public lemma spaceUsed_embed_le (tm : MultiTapeTM k Symbol State) (e : Fin k ↪ Fin k') + (cfg : Cfg k Symbol State input) (extraTapes : Fin k' → ℤ → Option Symbol) + (extraPos : Fin k' → ℤ) (n : ℕ) : + (tm.extendTapes e).spaceUsed (embed e cfg extraTapes extraPos) n + ≤ tm.spaceUsed cfg n + (k' - k) := by + classical + -- an embedded tape `e j` uses exactly the space of `tm`'s tape `j` + have key : ∀ j : Fin k, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n (e j) + = tm.spaceUsedByTape cfg n j := + fun j => congrArg Finset.card (visitedByTapeHead_embed_embed tm e cfg extraTapes extraPos n j) + -- a tape outside `range e` never moves, so it uses at most one cell + have bound1 : ∀ l, ¬ (∃ j, e j = l) → + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l ≤ 1 := by + intro l hl + refine le_trans (Finset.card_le_card ?_) (le_of_eq (Finset.card_singleton (extraPos l))) + intro z hz + obtain ⟨m, _, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [workTapePos_embed_of_not_range tm e cfg extraTapes extraPos m hl] + exact Finset.mem_singleton_self _ + calc (tm.extendTapes e).spaceUsed (embed e cfg extraTapes extraPos) n + = (∑ l ∈ Finset.univ \ Finset.univ.image e, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l) + + ∑ l ∈ Finset.univ.image e, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l := + (Finset.sum_sdiff (Finset.subset_univ _)).symm + _ ≤ (k' - k) + tm.spaceUsed cfg n := by + refine Nat.add_le_add ?_ (le_of_eq ?_) + · calc (∑ l ∈ Finset.univ \ Finset.univ.image e, + (tm.extendTapes e).spaceUsedByTape (embed e cfg extraTapes extraPos) n l) + ≤ ∑ _l ∈ Finset.univ \ Finset.univ.image e, 1 := by + refine Finset.sum_le_sum fun l hl => bound1 l ?_ + rw [Finset.mem_sdiff] at hl + rintro ⟨j, rfl⟩ + exact hl.2 (Finset.mem_image_of_mem e (Finset.mem_univ j)) + _ = k' - k := by + rw [Finset.sum_const, smul_eq_mul, mul_one, + Finset.card_sdiff_of_subset (Finset.subset_univ _), Finset.card_univ, + Fintype.card_fin, Finset.card_image_of_injective _ e.injective, Finset.card_univ, + Fintype.card_fin] + · rw [Finset.sum_image fun x _ y _ h => e.injective h] + simp only [spaceUsed] + exact Finset.sum_congr rfl fun j _ => key j + _ = tm.spaceUsed cfg n + (k' - k) := Nat.add_comm _ _ + +end Space + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean new file mode 100644 index 0000000000..c78c36f11a --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/InputFromTape.lean @@ -0,0 +1,324 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Mathlib.Algebra.BigOperators.Fin +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Reading the input from a work tape + +`inputFromTape tm mark` behaves like `tm`, except that it reads its input from a work tape — the +*virtual input tape* — instead of the real one, which it never touches. The virtual input head +lives at cell `p - 1` when the simulated input head is at position `p`, so the word cells +`0, …, len - 1` are the input positions `1, …, len` and the two boundary positions read the blanks +at cells `-1` and `len`. + +The one thing a blank cell cannot tell the machine is *which* boundary it is at — and it must +know, because the input head clamps there. Redirecting the input through a work tape is due to +Samuel Schlesinger (leanprover/cslib#872), who resolves the ambiguity by tracking a boundary +classification in the finite control. Here a *flag tape* is used instead, in the spirit of the +footprint anchors of the tidy normal form: a second fresh tape, whose head moves in lockstep with +the virtual input head, carries a single `mark` at cell `-1` — placed by a two-step prologue — so +the left boundary is recognised by reading the flag. Reading blank on both tapes then means the +right boundary. With the classification on a tape rather than in the control, the simulated +configuration determines the simulating one, and the redirection is an unconditional +step-semiconjugation: one `Turing.MultiTapeTM.runFrom_comm_of_step`, no bisimulation. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} + +/-- The clamped move of the virtual input head: at the left boundary (blank under the virtual +head, flag marked) left moves are blocked, at the right boundary (blank on both) right moves +are. -/ +@[expose] public def clampMove (wvip wflag : Option Symbol) (m : SignType) : SignType := + match wvip with + | some _ => m + | none => + match wflag with + | some _ => (match m with | SignType.neg => SignType.zero | _ => m) + | none => (match m with | SignType.pos => SignType.zero | _ => m) + +/-- `tm`, reading its input from the virtual input tape `⟨k, _⟩`, with the flag tape `⟨k + 1, _⟩` +marking the cell left of the input. The real input tape is never read and never moved. -/ +@[expose] public def inputFromTape (tm : MultiTapeTM k Symbol State) : + MultiTapeTM (k + 2) Symbol State where + q₀ := tm.q₀ + tr q _ work := + let a := tm.tr q (work ⟨k, by omega⟩) fun j => work (j.castAdd 2) + let m := clampMove (work ⟨k, by omega⟩) (work ⟨k + 1, by omega⟩) a.inputTape + { inputTape := 0 + workTapes := fun l => + if h : l.val < k then a.workTapes ⟨l.val, h⟩ else (none, m) + output := a.output + state := a.state } + +/-- A configuration of `tm` on input `I`, as the redirecting machine sees it, over an arbitrary +ambient input: `I` sits on the virtual input tape with the head at cell `inputPos - 1`, the flag +tape carries its mark at `-1` with its head in lockstep, and the ambient input head rests at +`1`. -/ +@[expose] public def inCfg (mark : Symbol) {I : List Symbol} (c : Cfg k Symbol State I) + (outerInput : List Symbol) : Cfg (k + 2) Symbol State outerInput := + ⟨c.state, 1, + fun l => if h : l.val < k then c.workTapes ⟨l.val, h⟩ + else if l.val = k then tapeOfList I + else Function.update (fun _ => none) (-1) (some mark), + fun l => if h : l.val < k then c.workTapePos ⟨l.val, h⟩ else ((c.inputPos.val : ℤ) - 1), + c.output⟩ + +section Projections + +variable {mark : Symbol} {I : List Symbol} {outerInput : List Symbol} + +@[simp] +public lemma inCfg_inputPos (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).inputPos = 1 := rfl + +@[simp] +public lemma inCfg_workTapes_castAdd (c : Cfg k Symbol State I) (j : Fin k) : + (inCfg mark c outerInput).workTapes (j.castAdd 2) = c.workTapes j := by + have h : (j.castAdd 2).val < k := j.isLt + change (if h : (j.castAdd 2).val < k then c.workTapes ⟨(j.castAdd 2).val, h⟩ else _) = _ + rw [dite_eq_left h] + exact congrArg _ (Fin.ext (by simp)) + +@[simp] +public lemma inCfg_workTapes_vip (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapes ⟨k, by omega⟩ = tapeOfList I := by + change (if h : k < k then _ else if (k : ℕ) = k then tapeOfList I else _) = _ + rw [dite_eq_right (by omega), ite_eq_left rfl] + +@[simp] +public lemma inCfg_workTapes_flag (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapes ⟨k + 1, by omega⟩ = + Function.update (fun _ => none) (-1) (some mark) := by + change (if h : k + 1 < k then _ else if k + 1 = k then _ else + Function.update (fun _ => none) (-1) (some mark)) = _ + rw [dite_eq_right (by omega), ite_eq_right (by omega)] + +@[simp] +public lemma inCfg_workTapePos_castAdd (c : Cfg k Symbol State I) (j : Fin k) : + (inCfg mark c outerInput).workTapePos (j.castAdd 2) = c.workTapePos j := by + have h : (j.castAdd 2).val < k := j.isLt + change (if h : (j.castAdd 2).val < k then c.workTapePos ⟨(j.castAdd 2).val, h⟩ else _) = _ + rw [dite_eq_left h] + exact congrArg _ (Fin.ext (by simp)) + +@[simp] +public lemma inCfg_workTapePos_vip (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapePos ⟨k, by omega⟩ = ((c.inputPos.val : ℤ) - 1) := by + change (if h : k < k then _ else ((c.inputPos.val : ℤ) - 1)) = _ + rw [dite_eq_right (by omega)] + +@[simp] +public lemma inCfg_workTapePos_flag (c : Cfg k Symbol State I) : + (inCfg mark c outerInput).workTapePos ⟨k + 1, by omega⟩ = ((c.inputPos.val : ℤ) - 1) := by + change (if h : k + 1 < k then _ else ((c.inputPos.val : ℤ) - 1)) = _ + rw [dite_eq_right (by omega)] + +@[simp] +public lemma inCfg_workTapeSymbols_castAdd (c : Cfg k Symbol State I) (j : Fin k) : + (inCfg mark c outerInput).workTapeSymbols (j.castAdd 2) = c.workTapeSymbols j := by + simp [Cfg.workTapeSymbols] + +/-- The virtual input head reads exactly what the simulated input head reads: the word cells are +the input positions, the two boundary cells are blank. -/ +public lemma vip_read (c : Cfg k Symbol State I) : + tapeOfList I ((c.inputPos.val : ℤ) - 1) = c.inputSymbol := by + rcases Nat.eq_zero_or_pos c.inputPos.val with h0 | h1 + · rw [show ((c.inputPos.val : ℤ) - 1) = Int.negSucc 0 from by omega, tapeOfList_negSucc, + inputSymbol_eq_none_of_boundary (Or.inl h0)] + · rw [show ((c.inputPos.val : ℤ) - 1) = ((c.inputPos.val - 1 : ℕ) : ℤ) from by omega, + tapeOfList_ofNat] + rcases Nat.lt_or_ge (c.inputPos.val) (I.length + 1) with hlt | hge + · rw [Cfg.inputSymbol, dite_eq_right (fun he => by rw [he] at h1; simp at h1), + dite_eq_right (fun he => by + have hv : c.inputPos.val = I.length + 1 := by rw [he] + omega)] + rw [List.getElem?_eq_getElem (by omega)] + · have hv : c.inputPos.val = I.length + 1 := by have := c.inputPos.isLt; omega + rw [List.getElem?_eq_none (by omega), inputSymbol_eq_none_of_boundary (Or.inr hv)] + +/-- The flag head reads the mark exactly at the left boundary. -/ +public lemma flag_read (mark : Symbol) (c : Cfg k Symbol State I) : + Function.update (fun _ => (none : Option Symbol)) (-1) (some mark) + ((c.inputPos.val : ℤ) - 1) = if c.inputPos.val = 0 then some mark else none := by + by_cases h0 : c.inputPos.val = 0 + · rw [ite_eq_left h0, show ((c.inputPos.val : ℤ) - 1) = -1 from by omega, Function.update_self] + · rw [ite_eq_right h0, Function.update_of_ne (by omega)] + +/-- The clamped move tracks the simulated input head exactly. -/ +public lemma clampMove_correct (mark : Symbol) (c : Cfg k Symbol State I) (m : SignType) : + ((moveInputPos c.inputPos m).val : ℤ) - 1 = + ((c.inputPos.val : ℤ) - 1) + + (clampMove c.inputSymbol (if c.inputPos.val = 0 then some mark else none) m : ℤ) := by + have hlen : c.inputPos.val ≤ I.length + 1 := by have := c.inputPos.isLt; omega + rcases Nat.eq_zero_or_pos c.inputPos.val with h0 | h1 + · -- left boundary: virtual head blank, flag marked + rw [inputSymbol_eq_none_of_boundary (Or.inl h0), ite_eq_left h0] + rcases m with _ | _ | _ <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, SignType.cast] <;> + split_ifs <;> omega + · rcases Nat.lt_or_ge (c.inputPos.val) (I.length + 1) with hlt | hge + · -- inside the input: virtual head nonblank + obtain ⟨b, hb⟩ : ∃ b, c.inputSymbol = some b := by + rw [Cfg.inputSymbol, dite_eq_right (fun he => by rw [he] at h1; simp at h1), + dite_eq_right (fun he => by + have hv : c.inputPos.val = I.length + 1 := by rw [he] + omega)] + exact ⟨_, rfl⟩ + rw [hb] + rcases m with _ | _ | _ <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, SignType.cast] <;> + split_ifs <;> omega + · -- right boundary: virtual head blank, flag unmarked + have hv : c.inputPos.val = I.length + 1 := by omega + rw [inputSymbol_eq_none_of_boundary (Or.inr hv), ite_eq_right (by omega)] + rcases m with _ | _ | _ <;> + simp only [clampMove, val_moveInputPos_eq, min_def, max_def, SignType.cast] <;> + split_ifs <;> omega + +/-- Reading the sim machine's input argument: the virtual input head reads what the simulated +input head reads. -/ +private lemma inCfg_vip_symbol (mark : Symbol) (c : Cfg k Symbol State I) + (outerInput : List Symbol) : + (inCfg mark c outerInput).workTapeSymbols ⟨k, by omega⟩ = c.inputSymbol := by + rw [Cfg.workTapeSymbols, inCfg_workTapes_vip, inCfg_workTapePos_vip, vip_read] + +/-- Reading the sim machine's flag: marked exactly at the left boundary. -/ +private lemma inCfg_flag_symbol (mark : Symbol) (c : Cfg k Symbol State I) + (outerInput : List Symbol) : + (inCfg mark c outerInput).workTapeSymbols ⟨k + 1, by omega⟩ = + (if c.inputPos.val = 0 then some mark else none) := by + rw [Cfg.workTapeSymbols, inCfg_workTapes_flag, inCfg_workTapePos_flag, flag_read] + +/-- Decompose a tape index of the redirecting machine: an original work tape, the virtual input +tape, or the flag tape. -/ +private lemma tape_cases (l : Fin (k + 2)) : + (∃ j : Fin k, l = j.castAdd 2 ∧ l.val < k) ∨ l = ⟨k, by omega⟩ ∨ l = ⟨k + 1, by omega⟩ := by + rcases Nat.lt_trichotomy l.val k with h | h | h + · refine Or.inl ⟨⟨l.val, h⟩, ?_, h⟩ + apply Fin.ext + simp + · exact Or.inr (Or.inl (Fin.ext (by simp [h]))) + · have := l.isLt + exact Or.inr (Or.inr (Fin.ext (by simp; omega))) + +/-- **The redirection is a step-semiconjugation.** One step of the machine reading its input from +the virtual tape mirrors one step of the original, under the embedding `inCfg`. -/ +public lemma step_inCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg k Symbol State I) (outerInput : List Symbol) : + tm.inputFromTape.step (inCfg mark c outerInput) = + inCfg mark (tm.step c) outerInput := by + cases hq : c.state with + | none => + have h1 : (inCfg mark c outerInput).state = none := by rw [inCfg]; exact hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (inCfg mark c outerInput).state = some q := by rw [inCfg]; exact hq + have harg : tm.inputFromTape.tr q (inCfg mark c outerInput).inputSymbol + (inCfg mark c outerInput).workTapeSymbols = + (let a := tm.tr q c.inputSymbol c.workTapeSymbols + let m := clampMove c.inputSymbol + (if c.inputPos.val = 0 then some mark else none) a.inputTape + { inputTape := 0 + workTapes := fun l => if h : l.val < k then a.workTapes ⟨l.val, h⟩ else (none, m) + output := a.output + state := a.state } : Action (k + 2) Symbol State) := by + simp only [inputFromTape, inCfg_vip_symbol, inCfg_flag_symbol, + inCfg_workTapeSymbols_castAdd] + rw [step_apply_of_state h1, harg] + set a := tm.tr q c.inputSymbol c.workTapeSymbols with ha + have hstepc : tm.step c = a.apply c := step_apply_of_state hq + rw [hstepc] + have hmc := clampMove_correct (I := I) mark c a.inputTape + have hip : (a.apply c).inputPos = moveInputPos c.inputPos a.inputTape := rfl + refine Cfg.ext rfl ?_ ?_ ?_ rfl + · simp only [Action.apply_inputPos, moveInputPos_zero, inCfg] + · funext l z + rcases tape_cases l with ⟨j, rfl, hjk⟩ | rfl | rfl + · simp only [Action.apply_workTapes, Fin.val_castAdd, dite_eq_left j.isLt, Fin.eta, + inCfg_workTapes_castAdd, inCfg_workTapePos_castAdd] + · have hnk : ¬ ((⟨k, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapes, dite_eq_right hnk, inCfg_workTapes_vip] + · have hnk1 : ¬ ((⟨k + 1, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapes, dite_eq_right hnk1, inCfg_workTapes_flag] + · funext l + rcases tape_cases l with ⟨j, rfl, hjk⟩ | rfl | rfl + · simp only [Action.apply_workTapePos, Fin.val_castAdd, dite_eq_left j.isLt, Fin.eta, + inCfg_workTapePos_castAdd] + · have hnk : ¬ ((⟨k, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapePos, dite_eq_right hnk, inCfg_workTapePos_vip, + Action.apply_inputPos] + omega + · have hnk1 : ¬ ((⟨k + 1, by omega⟩ : Fin (k + 2)).val < k) := by simp + simp only [Action.apply_workTapePos, dite_eq_right hnk1, inCfg_workTapePos_flag, + Action.apply_inputPos] + omega + +/-- The redirected run mirrors the original. -/ +public lemma runFrom_inCfg (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg k Symbol State I) (outerInput : List Symbol) (n : ℕ) : + tm.inputFromTape.runFrom (inCfg mark c outerInput) n = + inCfg mark (tm.runFrom c n) outerInput := + runFrom_comm_of_step (fun c => inCfg mark c outerInput) + (fun c => step_inCfg tm mark c outerInput) c n + +/-- **Space of the input-redirected machine.** The `k` inner tapes visit exactly what the original +does; the two extra tapes (virtual input, flag) each move only with the simulated input head, +which stays within `[-1, I.length]` — so they add at most `2 * (I.length + 2)`. -/ +public lemma spaceUsed_inputFromTape (tm : MultiTapeTM k Symbol State) (mark : Symbol) + (c : Cfg k Symbol State I) (outerInput : List Symbol) (n : ℕ) : + tm.inputFromTape.spaceUsed (inCfg mark c outerInput) n ≤ + tm.spaceUsed c n + 2 * (I.length + 2) := by + classical + have hmir : ∀ m, tm.inputFromTape.runFrom (inCfg mark c outerInput) m = + inCfg mark (tm.runFrom c m) outerInput := fun m => runFrom_inCfg tm mark c outerInput m + -- the inner tapes: same visited set as the original (heads agree under `inCfg`) + have hcast : ∀ j : Fin k, tm.inputFromTape.visitedByTapeHead (inCfg mark c outerInput) n + (j.castAdd 2) = tm.visitedByTapeHead c n j := by + intro j + refine Finset.image_congr fun m _ => ?_ + rw [hmir m, inCfg_workTapePos_castAdd] + -- an extra tape's head lies in `[-1, I.length]` at every step + have hextra : ∀ l : Fin (k + 2), l = ⟨k, by omega⟩ ∨ l = ⟨k + 1, by omega⟩ → + tm.inputFromTape.visitedByTapeHead (inCfg mark c outerInput) n l ⊆ + Finset.Icc (-1 : ℤ) (I.length : ℤ) := by + intro l hl z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [hmir m] + have hb := (tm.runFrom c m).inputPos.isLt + rcases hl with rfl | rfl + · rw [inCfg_workTapePos_vip]; exact Finset.mem_Icc.mpr ⟨by omega, by omega⟩ + · rw [inCfg_workTapePos_flag]; exact Finset.mem_Icc.mpr ⟨by omega, by omega⟩ + have hextra_card : ∀ l : Fin (k + 2), l = ⟨k, by omega⟩ ∨ l = ⟨k + 1, by omega⟩ → + tm.inputFromTape.spaceUsedByTape (inCfg mark c outerInput) n l ≤ I.length + 2 := by + intro l hl + refine le_trans (Finset.card_le_card (hextra l hl)) ?_ + rw [Int.card_Icc]; omega + -- split the tape sum: inner tapes + the two extra + rw [spaceUsed, Fin.sum_univ_add] + have hinner : ∑ j : Fin k, tm.inputFromTape.spaceUsedByTape (inCfg mark c outerInput) n + (j.castAdd 2) = tm.spaceUsed c n := by + rw [spaceUsed] + exact Finset.sum_congr rfl fun j _ => congrArg Finset.card (hcast j) + have htwo : ∑ j : Fin 2, tm.inputFromTape.spaceUsedByTape (inCfg mark c outerInput) n + (j.natAdd k) ≤ 2 * (I.length + 2) := by + rw [Fin.sum_univ_two] + have e0 := hextra_card ((0 : Fin 2).natAdd k) (Or.inl (Fin.ext (by simp))) + have e1 := hextra_card ((1 : Fin 2).natAdd k) (Or.inr (Fin.ext (by simp))) + omega + rw [hinner] + exact Nat.add_le_add_left htwo _ + + +end Projections + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean new file mode 100644 index 0000000000..ea7ffec0a9 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/OutputToTape.lean @@ -0,0 +1,230 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Mathlib.Algebra.BigOperators.Fin +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Redirecting the output to a work tape + +`outputToTape tm` behaves like `tm`, except that whatever `tm` would append to the write-only +output tape is written on a fresh work tape instead, whose head always stands at the write +frontier. The design is due to Samuel Schlesinger (leanprover/cslib#872). + +Since the output is append-only, the frontier position is a *function of the configuration* — +the length of the output so far — so the redirected machine mirrors the original through the +configuration map `outCfg`, an unconditional step-semiconjugation: the run lemma is one +application of `Turing.MultiTapeTM.runFrom_comm_of_step`, with no induction. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- `tm`, with its output writes redirected onto a fresh last work tape, whose head always stands +at the write frontier. -/ +@[expose] public def outputToTape (tm : MultiTapeTM k Symbol State) : + MultiTapeTM (k + 1) Symbol State where + q₀ := tm.q₀ + tr q inp work := + let a := tm.tr q inp fun j => work j.castSucc + { inputTape := a.inputTape + workTapes := Fin.lastCases + (match a.output with + | none => (none, 0) + | some s => (some (some s), 1)) + (fun j => a.workTapes j) + output := none + state := a.state } + +/-- A configuration of `tm`, as the redirected machine sees it: the output so far sits on the +last work tape with the head at its end, and the real output is empty. -/ +@[expose] public def outCfg (c : Cfg k Symbol State input) : + Cfg (k + 1) Symbol State input := + ⟨c.state, c.inputPos, + Fin.lastCases (tapeOfList c.output) (fun j => c.workTapes j), + Fin.lastCases (c.output.length : ℤ) (fun j => c.workTapePos j), + []⟩ + +@[simp] +public lemma outCfg_inputSymbol (c : Cfg k Symbol State input) : + (outCfg c).inputSymbol = c.inputSymbol := rfl + +@[simp] +public lemma outCfg_workTapes_last (c : Cfg k Symbol State input) : + (outCfg c).workTapes (Fin.last k) = tapeOfList c.output := by + change Fin.lastCases (motive := fun _ => ℤ → Option Symbol) (tapeOfList c.output) + (fun j => c.workTapes j) (Fin.last k) = _ + exact Fin.lastCases_last + +@[simp] +public lemma outCfg_workTapes_castSucc (c : Cfg k Symbol State input) (j : Fin k) : + (outCfg c).workTapes j.castSucc = c.workTapes j := by + change Fin.lastCases (motive := fun _ => ℤ → Option Symbol) (tapeOfList c.output) + (fun j => c.workTapes j) j.castSucc = _ + exact Fin.lastCases_castSucc j + +@[simp] +public lemma outCfg_workTapePos_last (c : Cfg k Symbol State input) : + (outCfg c).workTapePos (Fin.last k) = (c.output.length : ℤ) := by + change Fin.lastCases (motive := fun _ => ℤ) ((c.output.length : ℤ)) + (fun j => c.workTapePos j) (Fin.last k) = _ + exact Fin.lastCases_last + +@[simp] +public lemma outCfg_workTapePos_castSucc (c : Cfg k Symbol State input) (j : Fin k) : + (outCfg c).workTapePos j.castSucc = c.workTapePos j := by + change Fin.lastCases (motive := fun _ => ℤ) ((c.output.length : ℤ)) + (fun j => c.workTapePos j) j.castSucc = _ + exact Fin.lastCases_castSucc j + +@[simp] +public lemma outCfg_workTapeSymbols_castSucc (c : Cfg k Symbol State input) (j : Fin k) : + (outCfg c).workTapeSymbols j.castSucc = c.workTapeSymbols j := by + simp [Cfg.workTapeSymbols] + +/-- The redirection is a step-semiconjugation. -/ +public lemma step_outCfg (tm : MultiTapeTM k Symbol State) (c : Cfg k Symbol State input) : + tm.outputToTape.step (outCfg c) = outCfg (tm.step c) := by + cases hq : c.state with + | none => + have h1 : (outCfg c).state = none := hq + simp only [step, h1, hq] + | some q => + have h1 : (outCfg c).state = some q := hq + have hargs : (fun j : Fin k => (outCfg c).workTapeSymbols j.castSucc) = + c.workTapeSymbols := funext fun j => outCfg_workTapeSymbols_castSucc c j + simp only [step, h1, hq, outputToTape] + rw [hargs, outCfg_inputSymbol] + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + induction l using Fin.lastCases with + | last => + rcases hout : (tm.tr q c.inputSymbol c.workTapeSymbols).output with _ | sym + · simp [Action.apply, hout, Fin.lastCases_last] + · simp only [Action.apply, hout, Fin.lastCases_last, outCfg_workTapes_last, + outCfg_workTapePos_last, Option.toList_some, tapeOfList_append_single] + | cast j => + rcases hw : ((tm.tr q c.inputSymbol c.workTapeSymbols).workTapes j).1 with _ | w <;> + simp [Action.apply, hw, Fin.lastCases_castSucc] + · funext l + induction l using Fin.lastCases with + | last => + rcases hout : (tm.tr q c.inputSymbol c.workTapeSymbols).output with _ | sym <;> + simp [Action.apply, hout, Fin.lastCases_last, SignType.cast] + | cast j => + simp [Action.apply, Fin.lastCases_castSucc] + +/-- The redirected run mirrors the original. -/ +public lemma runFrom_outCfg (tm : MultiTapeTM k Symbol State) (c : Cfg k Symbol State input) + (n : ℕ) : + tm.outputToTape.runFrom (outCfg c) n = outCfg (tm.runFrom c n) := + runFrom_comm_of_step outCfg (step_outCfg tm) c n + +section WithOutput + +/-- `outputToTape tm` never writes the real output, so replacing it commutes with a step. -/ +public lemma step_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) + (c : Cfg (k + 1) Symbol State input) (out : List Symbol) : + tm.outputToTape.step (c.withOutput out) = (tm.outputToTape.step c).withOutput out := by + cases hq : c.state with + | none => + have h1 : (c.withOutput out).state = none := hq + rw [step_of_halt h1, step_of_halt hq] + | some q => + have h1 : (c.withOutput out).state = some q := hq + have hin : (c.withOutput out).inputSymbol = c.inputSymbol := rfl + have hws : (c.withOutput out).workTapeSymbols = c.workTapeSymbols := rfl + have hout : (tm.outputToTape.tr q c.inputSymbol c.workTapeSymbols).output = none := by + simp [outputToTape] + rw [step_apply_of_state h1, step_apply_of_state hq, hin, hws] + refine Cfg.ext rfl rfl ?_ ?_ ?_ + · funext l z; simp [Cfg.withOutput] + · funext l; simp [Cfg.withOutput] + · simp only [Action.apply_output, Cfg.withOutput_output, hout, Option.toList_none, + List.append_nil] + +/-- The redirected run commutes with the real output already present. -/ +public lemma runFrom_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) + (c : Cfg (k + 1) Symbol State input) (out : List Symbol) (n : ℕ) : + tm.outputToTape.runFrom (c.withOutput out) n = (tm.outputToTape.runFrom c n).withOutput out := + runFrom_comm_of_step (fun c => c.withOutput out) + (fun c => step_outputToTape_withOutput tm c out) c n + +/-- `outputToTape`'s space does not depend on the real output already present. -/ +public lemma spaceUsed_outputToTape_withOutput (tm : MultiTapeTM k Symbol State) + (c : Cfg (k + 1) Symbol State input) (out : List Symbol) (u : ℕ) : + tm.outputToTape.spaceUsed (c.withOutput out) u = tm.outputToTape.spaceUsed c u := by + refine spaceUsed_eq_of_workTapePos _ _ u fun m hm => ?_ + rw [runFrom_outputToTape_withOutput]; rfl + +end WithOutput + +/-- The initial configuration of the redirected machine is the original's through `outCfg`. -/ +public lemma initCfg_outputToTape (tm : MultiTapeTM k Symbol State) (input : List Symbol) : + tm.outputToTape.initCfg input = outCfg (tm.initCfg input) := by + refine Cfg.ext rfl rfl ?_ ?_ rfl + · funext l z + induction l using Fin.lastCases with + | last => simp [initCfg, Cfg.init] + | cast j => simp [initCfg, Cfg.init] + · funext l + induction l using Fin.lastCases with + | last => simp [initCfg, Cfg.init] + | cast j => simp [initCfg, Cfg.init] + +/-- The output can only grow. -/ +public lemma length_output_mono (tm : MultiTapeTM k Symbol State) + (c : Cfg k Symbol State input) (d : ℕ) : + c.output.length ≤ (tm.runFrom c d).output.length := by + induction d with + | zero => simp + | succ d ih => + rw [runFrom_succ_eq_step', step_output, List.length_append] + omega + +/-- Redirecting the output costs the length of the output, and nothing else: the frontier head +walks over exactly the cells of the written output. -/ +public lemma spaceUsed_outputToTape (tm : MultiTapeTM k Symbol State) + (c : Cfg k Symbol State input) (u : ℕ) : + tm.outputToTape.spaceUsed (outCfg c) u ≤ + tm.spaceUsed c u + ((tm.runFrom c u).output.length + 1) := by + have hmirror : ∀ m, tm.outputToTape.runFrom (outCfg c) m = outCfg (tm.runFrom c m) := + fun m => runFrom_outCfg tm c m + have hcast : ∀ j : Fin k, tm.outputToTape.visitedByTapeHead (outCfg c) u j.castSucc = + tm.visitedByTapeHead c u j := by + intro j + refine Finset.image_congr fun m _ => ?_ + rw [hmirror m, outCfg_workTapePos_castSucc] + have hlast : tm.outputToTape.visitedByTapeHead (outCfg c) u (Fin.last k) ⊆ + Finset.Icc (c.output.length : ℤ) ((tm.runFrom c u).output.length : ℤ) := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [hmirror m, outCfg_workTapePos_last] + have h1 := length_output_mono tm c m + have h2 : (tm.runFrom c m).output.length ≤ (tm.runFrom c u).output.length := by + have h := length_output_mono tm (tm.runFrom c m) (u - m) + rw [← runFrom_add, show m + (u - m) = u from by omega] at h + exact h + exact Finset.mem_Icc.mpr ⟨by omega, by omega⟩ + calc tm.outputToTape.spaceUsed (outCfg c) u + = (∑ j : Fin k, tm.outputToTape.spaceUsedByTape (outCfg c) u j.castSucc) + + tm.outputToTape.spaceUsedByTape (outCfg c) u (Fin.last k) := + Fin.sum_univ_castSucc _ + _ ≤ tm.spaceUsed c u + ((tm.runFrom c u).output.length + 1) := by + refine Nat.add_le_add (le_of_eq ?_) ?_ + · exact Finset.sum_congr rfl fun j _ => congrArg Finset.card (hcast j) + · calc tm.outputToTape.spaceUsedByTape (outCfg c) u (Fin.last k) + ≤ (Finset.Icc (c.output.length : ℤ) + ((tm.runFrom c u).output.length : ℤ)).card := Finset.card_le_card hlast + _ = (((tm.runFrom c u).output.length : ℤ) + 1 - (c.output.length : ℤ)).toNat := + Int.card_Icc _ _ + _ ≤ (tm.runFrom c u).output.length + 1 := by omega + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean new file mode 100644 index 0000000000..1518222190 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Repeat.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas +public import Mathlib.Basic.Finite.Sum + +/-! +# Repeating a machine until a tape signals stop + +`repeatTM i x tm` runs `tm` over and over. After each run of `tm`, it inspects the symbol under the +head of work tape `i`: if it is `some x` the loop halts, otherwise `tm` is started again on the +tapes as it left them. This is the loop-back control combinator: the state space is `State₀ ⊕ +Unit`, where `Sum.inr ()` is a fresh *check* state; `tm`'s halting transition is redirected to it, +so the inspection costs one extra step per round and the handoff back to `tm` costs no step. + +The specification `exists_transformsTapes_repeat` is stated for a family indexed by `J`, with a +round predicate `P j n` describing the tapes after `n` rounds and a stopping predicate `R j`. As +long as round `n < N j` leaves the flag unequal to `x`, the loop keeps going; round `N j` leaves it +equal to `x`, so the loop halts. Because every round begins from a `wordsCfg` (all heads at the +start of their words), the configurations thread cleanly round to round. + +The time bound is `(N j + 1) * (t j + 1)`: there are `N j + 1` rounds, each of at most `t j` steps +of `tm` plus one inspection step. The space bound `2 * k * s j + k` is **independent of the number +of rounds**: every round starts with the heads at `0` and uses at most `s j` cells, so on each tape +that round's visited cells form an interval around `0` contained in `[-s j, s j]`; the whole run's +visited set is the union of the rounds' sets, still within `[-s j, s j]`, hence at most `2 * s j + +1` cells per tape. + +## Main results + +* `Turing.MultiTapeTM.exists_transformsTapes_repeat`: from a family of per-round transformations + and a stopping transformation, a single machine that loops until tape `i` shows `x`, with time + bound `(N j + 1) * (t j + 1)` and space bound `2 * k * s j + k`. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {State₀ : Type*} {input : List Bool} + +namespace Repeat + +/-- The looping machine. On a live state `Sum.inl q` it runs `tm`, but redirects `tm`'s halting +transition to the fresh check state `Sum.inr ()`. On the check state it reads the symbol under +tape `i`'s head: if it is `some x` the machine halts, otherwise it restarts `tm` from its initial +state, writing nothing and moving no head. -/ +private def repeatTM (i : Fin k) (x : Bool) (tm : MultiTapeTM k Bool State₀) : + MultiTapeTM k Bool (State₀ ⊕ Unit) where + q₀ := .inl tm.q₀ + tr q inp work := + match q with + | .inl q => + let a := tm.tr q inp work + { a with state := some (a.state.elim (.inr ()) .inl) } + | .inr _ => + if work i = some x then + { inputTape := 0, workTapes := fun _ => (none, 0), output := none, state := none } + else + { inputTape := 0, workTapes := fun _ => (none, 0), output := none, + state := some (.inl tm.q₀) } + +variable {i : Fin k} {x : Bool} {tm : MultiTapeTM k Bool State₀} + +/-- A configuration of `tm`, embedded into the looping machine: a halted state is sent to the +check state `Sum.inr ()`, a live state is carried by `Sum.inl`. Under this map the machine mirrors +`tm` step for step while `tm` is live, and lands on the check state exactly when `tm` halts. -/ +private def leftCfg (cfg : Cfg k Bool State₀ input) : Cfg k Bool (State₀ ⊕ Unit) input := + cfg.mapState (fun st => some (st.elim (.inr ()) .inl)) + +@[simp] +private lemma workTapePos_leftCfg (cfg : Cfg k Bool State₀ input) : + (leftCfg cfg).workTapePos = cfg.workTapePos := rfl + +private lemma leftCfg_wordsCfg (q : Option State₀) (ws : Fin k → List Bool) (out : List Bool) : + leftCfg (input := input) (wordsCfg input q ws out) = + wordsCfg input (some (q.elim (.inr ()) .inl)) ws out := rfl + +/-- On `tm`'s live configurations, the looping machine mirrors `tm` step for step. -/ +private lemma step_leftCfg (cfg : Cfg k Bool State₀ input) (h : cfg.state ≠ none) : + (repeatTM i x tm).step (leftCfg cfg) = leftCfg (tm.step cfg) := by + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h + have h1 : (leftCfg cfg).state = some (Sum.inl q : State₀ ⊕ Unit) := by + simp [leftCfg, Cfg.mapState, hq] + simp only [step, h1, hq] + rfl + +/-- While `tm` is live, the looping machine mirrors it. -/ +private lemma runFrom_leftCfg (cfg : Cfg k Bool State₀ input) (n : ℕ) + (h : ∀ m < n, (tm.runFrom cfg m).state ≠ none) : + (repeatTM i x tm).runFrom (leftCfg cfg) n = leftCfg (tm.runFrom cfg n) := by + induction n with + | zero => rfl + | succ n ih => + rw [runFrom_succ_eq_step', runFrom_succ_eq_step', ih fun m hm => h m (by omega), + step_leftCfg _ (h n (by omega))] + +/-- The run of the looping machine on a starting `wordsCfg`, while `tm` is live. -/ +private lemma runFrom_left_wordsCfg (w : Fin k → List Bool) (out : List Bool) (n : ℕ) + (hact : ∀ m < n, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) : + (repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) n = + leftCfg (tm.runFrom (wordsCfg input (some tm.q₀) w out) n) := by + have h : wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inl tm.q₀)) w out = + leftCfg (wordsCfg input (some tm.q₀) w out) := rfl + rw [h, runFrom_leftCfg _ n hact] + +/-- The check step, when tape `i` shows `x`: the machine halts, leaving the words untouched. -/ +private lemma step_check_halt (ws : Fin k → List Bool) (out : List Bool) + (h : (ws i).head? = some x) : + (repeatTM i x tm).step (wordsCfg input (some (Sum.inr ())) ws out) = + wordsCfg input none ws out := by + have hstate : (wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inr ())) ws out).state = + some (Sum.inr ()) := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [repeatTM, Cfg.workTapeSymbols, tapeOfList_zero, h, wordsCfg, Action.apply, SignType.cast] + +/-- The check step, when tape `i` does not show `x`: the machine restarts `tm` from its initial +state, leaving the words untouched. -/ +private lemma step_check_restart (ws : Fin k → List Bool) (out : List Bool) + (h : ¬ (ws i).head? = some x) : + (repeatTM i x tm).step (wordsCfg input (some (Sum.inr ())) ws out) = + wordsCfg input (some (Sum.inl tm.q₀)) ws out := by + have hstate : (wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inr ())) ws out).state = + some (Sum.inr ()) := rfl + rw [step_apply_of_state hstate] + refine Cfg.ext ?_ ?_ ?_ ?_ ?_ <;> + simp [repeatTM, Cfg.workTapeSymbols, tapeOfList_zero, h, wordsCfg, Action.apply, SignType.cast] + +/-- On the check state, the step moves no work-tape head. -/ +private lemma check_step_workTapePos (c : Cfg k Bool (State₀ ⊕ Unit) input) + (hstate : c.state = some (Sum.inr ())) (l : Fin k) : + ((repeatTM i x tm).step c).workTapePos l = c.workTapePos l := by + have h2 : (((repeatTM i x tm).tr (Sum.inr ()) c.inputSymbol c.workTapeSymbols).workTapes l).2 + = 0 := by + simp only [repeatTM] + split <;> rfl + rw [step_workTapePos_of_state hstate l, h2] + simp + +/-- One full round takes the loop from a `wordsCfg` on `tm`'s initial state to a `wordsCfg` on +`tm`'s initial state, when tape `i` does not show `x`. -/ +private lemma runFrom_round_restart (w w' : Fin k → List Bool) (out : List Bool) (u : ℕ) + (hact : ∀ m < u, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) + (hrun_u : tm.runFrom (wordsCfg input (some tm.q₀) w out) u = wordsCfg input none w' out) + (hrestart : ¬ (w' i).head? = some x) : + (repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) (u + 1) = + wordsCfg input (some (Sum.inl tm.q₀)) w' out := by + rw [runFrom_succ_eq_step', runFrom_left_wordsCfg w out u hact, hrun_u] + exact step_check_restart w' out hrestart + +/-- The last round: when tape `i` shows `x`, the loop halts on a `wordsCfg`. -/ +private lemma runFrom_round_halt (w w' : Fin k → List Bool) (out : List Bool) (u : ℕ) + (hact : ∀ m < u, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) + (hrun_u : tm.runFrom (wordsCfg input (some tm.q₀) w out) u = wordsCfg input none w' out) + (hstop : (w' i).head? = some x) : + (repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) (u + 1) = + wordsCfg input none w' out := by + rw [runFrom_succ_eq_step', runFrom_left_wordsCfg w out u hact, hrun_u] + exact step_check_halt w' out hstop + +/-- A `tm`-run started at a `wordsCfg` (head at `0`) using at most `s0` cells stays, on each tape, +within `[-s0, s0]`. -/ +private lemma visited_subset_Icc (cfg : Cfg k Bool State₀ input) (u : ℕ) (l : Fin k) (s0 : ℕ) + (h0 : cfg.workTapePos l = 0) (hsp : tm.spaceUsed cfg u ≤ s0) : + tm.visitedByTapeHead cfg u l ⊆ Finset.Icc (-(s0 : ℤ)) (s0 : ℤ) := by + obtain ⟨lo, hi, hlo, hhi, hvisited⟩ := tm.exists_visitedByTapeHead_eq_Icc cfg u l + rw [h0] at hlo hhi + have hcard : (tm.visitedByTapeHead cfg u l).card ≤ s0 := + le_trans (tm.spaceUsedByTape_le_spaceUsed cfg u l) hsp + rw [hvisited, Int.card_Icc] at hcard + intro z hz + rw [hvisited] at hz + rw [Finset.mem_Icc] at hz ⊢ + omega + +/-- **The per-round space confinement.** Every configuration reached within one round keeps every +work-tape head inside `[-s0, s0]`: during `tm`'s phase because that phase starts with the head at +`0` and uses at most `s0` cells, and at the check step because it moves no head. -/ +private lemma round_Icc (w w' : Fin k → List Bool) (out : List Bool) (u : ℕ) (s0 : ℕ) + (hact : ∀ m < u, (tm.runFrom (wordsCfg input (some tm.q₀) w out) m).state ≠ none) + (hrun_u : tm.runFrom (wordsCfg input (some tm.q₀) w out) u = wordsCfg input none w' out) + (hsp : tm.spaceUsed (wordsCfg input (some tm.q₀) w out) u ≤ s0) : + ∀ m ≤ u + 1, ∀ l : Fin k, + ((repeatTM i x tm).runFrom (wordsCfg input (some (Sum.inl tm.q₀)) w out) m).workTapePos l + ∈ Finset.Icc (-(s0 : ℤ)) (s0 : ℤ) := by + intro m hm l + rcases Nat.lt_or_ge m (u + 1) with hlt | hge + · -- during `tm`'s phase: the head is in `tm`'s visited set, which lies in `[-s0, s0]` + have hmu : m ≤ u := by omega + rw [runFrom_left_wordsCfg w out m (fun r hr => hact r (by omega)), workTapePos_leftCfg] + apply visited_subset_Icc (tm := tm) _ u l s0 rfl hsp + exact mem_visitedByTapeHead.mpr ⟨m, by omega, rfl⟩ + · -- the check step: the head does not move, and it sits at `0` + have hmeq : m = u + 1 := by omega + subst hmeq + rw [runFrom_succ_eq_step', runFrom_left_wordsCfg w out u hact, hrun_u] + rw [check_step_workTapePos _ (by rw [leftCfg_wordsCfg]; rfl) l] + rw [leftCfg_wordsCfg] + simp only [Finset.mem_Icc, wordsCfg_workTapePos] + omega + +end Repeat + +open Repeat in +/-- **Repeating a machine until a tape signals stop.** Given a family of per-round +transformations `hround` (each of which advances the round predicate `P j n` to `P j (n+1)` while +leaving tape `i`'s head symbol unequal to `x`) and a stopping transformation `hstop` (which +establishes `R j` while leaving tape `i`'s head symbol equal to `x`), a single machine loops `tm`, +inspecting tape `i` after each round, until that head symbol equals `x`. It performs `N j + 1` +rounds, so the time bound is `(N j + 1) * (t j + 1)`; because every round starts with the heads at +the start of their words and uses at most `s j` cells, the space bound `2 * k * s j + k` is +independent of the number of rounds. -/ +public theorem exists_transformsTapes_repeat {J : Type*} {k : ℕ} (i : Fin k) (x : Bool) + {State₀ : Type} [Finite State₀] {tm : MultiTapeTM k Bool State₀} + {P : J → ℕ → (input : List Bool) → (Fin k → List Bool) → Prop} + {R : J → (input : List Bool) → (Fin k → List Bool) → Prop} + {N : J → ℕ} {t s : J → ℕ} + (hround : ∀ (j : J) (n : ℕ), n < N j → TransformsTapes tm (P j n) + (fun input _ ws' => P j (n + 1) input ws' ∧ (ws' i).head? ≠ some x) (t j) (s j)) + (hstop : ∀ j : J, TransformsTapes tm (P j (N j)) + (fun input _ ws' => R j input ws' ∧ (ws' i).head? = some x) (t j) (s j)) : + ∃ (State : Type) (_ : Finite State) (tm' : MultiTapeTM k Bool State), ∀ j : J, + TransformsTapes tm' (P j 0) (fun input _ ws' => R j input ws') + ((N j + 1) * (t j + 1)) (2 * k * s j + k) := by + refine ⟨State₀ ⊕ Unit, inferInstance, repeatTM i x tm, fun j input ws out hP0 => ?_⟩ + rw [show (repeatTM i x tm).q₀ = Sum.inl tm.q₀ from rfl] + set start := wordsCfg (State := State₀ ⊕ Unit) input (some (Sum.inl tm.q₀)) ws out with hstart + -- After `n ≤ N j` rounds, the loop is back on `tm`'s initial state with words satisfying `P j n`, + -- has taken at most `n * (t j + 1)` steps, and has kept every head inside `[-s j, s j]`. + have hrec : ∀ n, n ≤ N j → ∃ (T : ℕ) (wsn : Fin k → List Bool), + (repeatTM i x tm).runFrom start T = wordsCfg input (some (Sum.inl tm.q₀)) wsn out ∧ + P j n input wsn ∧ T ≤ n * (t j + 1) ∧ + ∀ m ≤ T, ∀ l, ((repeatTM i x tm).runFrom start m).workTapePos l + ∈ Finset.Icc (-(s j : ℤ)) (s j : ℤ) := by + intro n + induction n with + | zero => + intro _ + refine ⟨0, ws, by rw [runFrom_zero, hstart], hP0, by omega, fun m hm l => ?_⟩ + have : m = 0 := by omega + subst this + rw [runFrom_zero, hstart] + simp only [Finset.mem_Icc, wordsCfg_workTapePos] + omega + | succ n ih => + intro hn + obtain ⟨T, wsn, hrun, hPn, hT, hIcc⟩ := ih (by omega) + obtain ⟨τ, hτ, wsn', hrunTm, hQ, hsp⟩ := hround j n (by omega) input wsn out hPn + obtain ⟨u, hu, huhalt, huactive⟩ := exists_minimal_halting_time tm + (wordsCfg input (some tm.q₀) wsn out) τ (by rw [hrunTm]; rfl) + have hu_run : tm.runFrom (wordsCfg input (some tm.q₀) wsn out) u = + wordsCfg input none wsn' out := by + rw [← runFrom_eq_of_halt tm _ hu huhalt, hrunTm] + have hsp_u : tm.spaceUsed (wordsCfg input (some tm.q₀) wsn out) u ≤ s j := + le_trans (spaceUsed_mono tm _ hu) hsp + refine ⟨T + (u + 1), wsn', ?_, hQ.1, ?_, ?_⟩ + · rw [runFrom_add, hrun, runFrom_round_restart wsn wsn' out u huactive hu_run hQ.2] + · have hexp : (n + 1) * (t j + 1) = n * (t j + 1) + (t j + 1) := by rw [add_mul, one_mul] + have : u ≤ t j := le_trans hu hτ + omega + · intro m hm l + rcases Nat.lt_or_ge m (T + 1) with hmT | hmT + · exact hIcc m (by omega) l + · obtain ⟨m', rfl⟩ : ∃ m', m = T + m' := ⟨m - T, by omega⟩ + rw [runFrom_add, hrun] + exact round_Icc wsn wsn' out u (s j) huactive hu_run hsp_u m' (by omega) l + -- The stopping round: apply `hstop`, take the minimal halting time, and read off `R j`. + obtain ⟨T, wsN, hrun, hPN, hT, hIcc⟩ := hrec (N j) le_rfl + obtain ⟨τ, hτ, ws', hrunTm, hQ, hsp⟩ := hstop j input wsN out hPN + obtain ⟨u, hu, huhalt, huactive⟩ := exists_minimal_halting_time tm + (wordsCfg input (some tm.q₀) wsN out) τ (by rw [hrunTm]; rfl) + have hu_run : tm.runFrom (wordsCfg input (some tm.q₀) wsN out) u = + wordsCfg input none ws' out := by + rw [← runFrom_eq_of_halt tm _ hu huhalt, hrunTm] + have hsp_u : tm.spaceUsed (wordsCfg input (some tm.q₀) wsN out) u ≤ s j := + le_trans (spaceUsed_mono tm _ hu) hsp + -- The head stays in `[-s j, s j]` for the whole run. + have hIccAll : ∀ m ≤ T + (u + 1), ∀ l, + ((repeatTM i x tm).runFrom start m).workTapePos l ∈ Finset.Icc (-(s j : ℤ)) (s j : ℤ) := by + intro m hm l + rcases Nat.lt_or_ge m (T + 1) with hmT | hmT + · exact hIcc m (by omega) l + · obtain ⟨m', rfl⟩ : ∃ m', m = T + m' := ⟨m - T, by omega⟩ + rw [runFrom_add, hrun] + exact round_Icc wsN ws' out u (s j) huactive hu_run hsp_u m' (by omega) l + refine ⟨T + (u + 1), ?_, ws', ?_, hQ.1, ?_⟩ + · -- time bound + have hexp : (N j + 1) * (t j + 1) = N j * (t j + 1) + (t j + 1) := by rw [add_mul, one_mul] + have : u ≤ t j := le_trans hu hτ + omega + · -- the run ends in the halting `wordsCfg` + rw [runFrom_add, hrun, runFrom_round_halt wsN ws' out u huactive hu_run hQ.2] + · -- space bound: each tape's visited set lies in `[-s j, s j]`, so has at most `2 * s j + 1` + -- cells, and there are `k` tapes + have hbound : ∀ l : Fin k, + (repeatTM i x tm).spaceUsedByTape start (T + (u + 1)) l ≤ 2 * s j + 1 := by + intro l + have hsub : (repeatTM i x tm).visitedByTapeHead start (T + (u + 1)) l ⊆ + Finset.Icc (-(s j : ℤ)) (s j : ℤ) := by + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + exact hIccAll m (by omega) l + calc (repeatTM i x tm).spaceUsedByTape start (T + (u + 1)) l + ≤ (Finset.Icc (-(s j : ℤ)) (s j : ℤ)).card := Finset.card_le_card hsub + _ = 2 * s j + 1 := by rw [Int.card_Icc]; omega + calc (repeatTM i x tm).spaceUsed start (T + (u + 1)) + = ∑ l : Fin k, (repeatTM i x tm).spaceUsedByTape start (T + (u + 1)) l := rfl + _ ≤ ∑ _l : Fin k, (2 * s j + 1) := Finset.sum_le_sum fun l _ => hbound l + _ = 2 * k * s j + k := by + rw [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul, Nat.cast_id, + Nat.mul_add, Nat.mul_one, ← Nat.mul_assoc, Nat.mul_comm k 2] + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean new file mode 100644 index 0000000000..adb91c3739 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindInput.lean @@ -0,0 +1,312 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# A machine that rewinds the input head + +A three-state machine that returns the input head to position `1` — the first input symbol — from +an arbitrary starting configuration and halts there. It never writes to a work tape, never moves a +work-tape head and never outputs, so a combinator can run it between two phases of a computation +to re-normalise the input head without disturbing anything else. + +In its initial state `probe` the machine reads the cell under the input head. A symbol means the +head is inside the input (positions `1, …, input.length`) and the machine starts walking left. A +blank means the head is at one of the two boundary positions `0` and `input.length + 1`, and one +more probe a cell to the left disambiguates: in state `probe2`, a symbol identifies the right +boundary of a nonempty input and the machine walks left, while a blank means the head started at +the left boundary or the input is empty, so moving right lands on position `1` and the machine +halts. In state `walk` the machine moves left over symbols; the first blank is the cell at +position `0`, and the halting transition moves right, onto position `1`. + +From any starting position the run halts within `input.length + 2` steps. + +## Main results + +* `Turing.MultiTapeTM.exists_rewindInput`: the machine that rewinds the input head. +-/ + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol : Type*} {input : List Symbol} + +/-- The control states of the rewinding machine: `probe` reads the starting cell, `probe2` reads +the cell to its left when the first read was blank, and `walk` moves left towards the input +boundary. -/ +inductive RewindState : Type + | probe + | probe2 + | walk + +instance : Finite RewindState := + Finite.of_injective + (fun q => match q with + | .probe => (0 : Fin 3) + | .probe2 => 1 + | .walk => 2) + (fun a b h => by cases a <;> cases b <;> first | rfl | exact absurd h (by decide)) + +/-- The rewinding machine. Reading a symbol, every state turns to `walk` and moves the input head +left; reading a blank, `probe` moves left into `probe2` while `probe2` and `walk` move right and +halt. No work tape is ever written or moved and nothing is output. -/ +def rewindInput (k : ℕ) (Symbol : Type*) : MultiTapeTM k Symbol RewindState where + q₀ := .probe + tr q inp _ := + match q, inp with + | .probe, some _ => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .walk } + | .probe, none => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .probe2 } + | .probe2, some _ => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .walk } + | .probe2, none => + { inputTape := .pos, workTapes := fun _ => (none, 0), output := none, + state := none } + | .walk, some _ => + { inputTape := .neg, workTapes := fun _ => (none, 0), output := none, + state := some .walk } + | .walk, none => + { inputTape := .pos, workTapes := fun _ => (none, 0), output := none, + state := none } + +namespace Rewind + +variable {w : Fin k → ℤ → Option Symbol} {wp : Fin k → ℤ} {out : List Symbol} + {p : Fin (input.length + 2)} + +/-- The value of the input position after a left move: truncated subtraction in `ℕ` captures the +clamping at the left boundary. -/ +lemma val_moveInputPos_neg {n : ℕ} (p : Fin (n + 2)) : + (moveInputPos p .neg).val = p.val - 1 := by + rcases eq_or_ne p 0 with rfl | h + · simp + · rw [moveInputPos_neg_of_ne_left p h] + +/-- The value of the input position after a right move away from the right boundary. -/ +lemma val_moveInputPos_pos {n : ℕ} (p : Fin (n + 2)) (h : p.val ≠ n + 1) : + (moveInputPos p .pos).val = p.val + 1 := by + rw [moveInputPos_pos_of_ne_right p h] + +/-- Configurations that differ only in provably equal input positions are equal. -/ +lemma cfg_congr {q : Option RewindState} {p p' : Fin (input.length + 2)} (h : p.val = p'.val) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input) = ⟨q, p', w, wp, out⟩ := by + rw [Fin.ext h] + +/-- The symbol read with the input head inside the input. -/ +lemma inputSymbol_mk_eq_some {q : Option RewindState} (h1 : p.val ≠ 0) + (h2 : p.val ≠ input.length + 1) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = + some (input[p.val - 1]'(by have := p.isLt; omega)) := + inputSymbolInner (p.val - 1) (show p.val = 1 + (p.val - 1) by omega) + (by have := p.isLt; omega) + +/-- The blank read at the left boundary. -/ +lemma inputSymbol_mk_eq_none_left {q : Option RewindState} (h : p = 0) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none := by + subst h + simp [Cfg.inputSymbol] + +/-- The blank read at the right boundary. -/ +lemma inputSymbol_mk_eq_none_right {q : Option RewindState} (h : p.val = input.length + 1) : + (⟨q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none := by + grind [Cfg.inputSymbol] + +/-- No action of the rewinding machine writes to a work tape or moves a work head. -/ +lemma tr_workTapes (q : RewindState) (inp : Option Symbol) (work : Fin k → Option Symbol) + (i : Fin k) : ((rewindInput k Symbol).tr q inp work).workTapes i = (none, 0) := by + cases q <;> cases inp <;> rfl + +/-- The rewinding machine never outputs. -/ +lemma tr_output (q : RewindState) (inp : Option Symbol) (work : Fin k → Option Symbol) : + ((rewindInput k Symbol).tr q inp work).output = none := by + cases q <;> cases inp <;> rfl + +/-- Applying an action that writes nothing, moves no work head and outputs nothing changes only +the state and the input position. -/ +lemma apply_action (a : Action k Symbol RewindState) + (ha1 : ∀ i, a.workTapes i = (none, 0)) (ha2 : a.output = none) + (c : Cfg k Symbol RewindState input) : + a.apply c = + ⟨a.state, moveInputPos c.inputPos a.inputTape, c.workTapes, c.workTapePos, c.output⟩ := by + refine Cfg.ext rfl rfl (funext fun i => ?_) (funext fun i => ?_) ?_ <;> + simp [ha1, ha2, SignType.cast] + +/-- One step from a live state applies the transition to the symbols read. -/ +lemma step_mk (q : RewindState) : + (rewindInput k Symbol).step ⟨some q, p, w, wp, out⟩ = + ((rewindInput k Symbol).tr q + (Cfg.inputSymbol ⟨some q, p, w, wp, out⟩) + (Cfg.workTapeSymbols ⟨some q, p, w, wp, out⟩)).apply + ⟨some q, p, w, wp, out⟩ := rfl + +/-- Reading a symbol, every state turns to `walk` and moves the input head left. -/ +lemma step_read (q : RewindState) {s : Symbol} + (hs : (⟨some q, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = some s) : + (rewindInput k Symbol).step ⟨some q, p, w, wp, out⟩ = + ⟨some .walk, moveInputPos p .neg, w, wp, out⟩ := by + rw [step_mk, hs] + cases q <;> exact apply_action _ (fun _ => rfl) rfl _ + +/-- Reading a blank in `probe`, the machine moves left and probes again. -/ +lemma step_probe_none + (hs : (⟨some .probe, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none) : + (rewindInput k Symbol).step ⟨some .probe, p, w, wp, out⟩ = + ⟨some .probe2, moveInputPos p .neg, w, wp, out⟩ := by + rw [step_mk, hs] + exact apply_action _ (fun _ => rfl) rfl _ + +/-- Reading a blank in `probe2`, the head started at the left boundary or the input is empty: +the machine moves right, onto position `1`, and halts. -/ +lemma step_probe2_none + (hs : (⟨some .probe2, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none) : + (rewindInput k Symbol).step ⟨some .probe2, p, w, wp, out⟩ = + ⟨none, moveInputPos p .pos, w, wp, out⟩ := by + rw [step_mk, hs] + exact apply_action _ (fun _ => rfl) rfl _ + +/-- Reading a blank in `walk`, the head is at position `0`: the machine moves right, onto +position `1`, and halts. -/ +lemma step_walk_none + (hs : (⟨some .walk, p, w, wp, out⟩ : Cfg k Symbol RewindState input).inputSymbol = none) : + (rewindInput k Symbol).step ⟨some .walk, p, w, wp, out⟩ = + ⟨none, moveInputPos p .pos, w, wp, out⟩ := by + rw [step_mk, hs] + exact apply_action _ (fun _ => rfl) rfl _ + +/-- One step never changes the work tapes, the work heads or the output. -/ +lemma step_frame (c : Cfg k Symbol RewindState input) : + ((rewindInput k Symbol).step c).workTapes = c.workTapes ∧ + ((rewindInput k Symbol).step c).workTapePos = c.workTapePos ∧ + ((rewindInput k Symbol).step c).output = c.output := by + obtain ⟨q, p, w, wp, out⟩ := c + cases q with + | none => exact ⟨rfl, rfl, rfl⟩ + | some q => + rw [step_mk, apply_action _ (fun i => tr_workTapes q _ _ i) (tr_output q _ _)] + exact ⟨rfl, rfl, rfl⟩ + +/-- The run never changes the work tapes, the work heads or the output. -/ +lemma runFrom_frame (c : Cfg k Symbol RewindState input) (m : ℕ) : + ((rewindInput k Symbol).runFrom c m).workTapes = c.workTapes ∧ + ((rewindInput k Symbol).runFrom c m).workTapePos = c.workTapePos ∧ + ((rewindInput k Symbol).runFrom c m).output = c.output := by + induction m with + | zero => exact ⟨rfl, rfl, rfl⟩ + | succ m ih => + obtain ⟨h1, h2, h3⟩ := step_frame ((rewindInput k Symbol).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, h2.trans ih.2.1, h3.trans ih.2.2⟩ + +/-- One step of the run, as an equation on `runFrom`. -/ +lemma runFrom_one (c : Cfg k Symbol RewindState input) : + (rewindInput k Symbol).runFrom c 1 = (rewindInput k Symbol).step c := rfl + +/-- Two steps of the run, as an equation on `runFrom`. -/ +lemma runFrom_two (c : Cfg k Symbol RewindState input) : + (rewindInput k Symbol).runFrom c 2 = + (rewindInput k Symbol).step ((rewindInput k Symbol).step c) := rfl + +/-- From `walk` at position `j ≤ input.length` the machine reaches the halting configuration with +the input head at position `1` in `j + 1` steps. -/ +lemma runFrom_walk (j : ℕ) : + ∀ p : Fin (input.length + 2), p.val = j → j ≤ input.length → + (rewindInput k Symbol).runFrom ⟨some .walk, p, w, wp, out⟩ (j + 1) = + ⟨none, 1, w, wp, out⟩ := by + induction j with + | zero => + intro p hp _ + obtain rfl : p = 0 := Fin.ext (by simpa using hp) + rw [runFrom_succ_eq_step', runFrom_zero, step_walk_none (inputSymbol_mk_eq_none_left rfl)] + refine cfg_congr ?_ + rw [val_moveInputPos_pos 0 (by simp)] + simp + | succ j ih => + intro p hp hj + rw [runFrom_succ_eq_step, step_read _ (inputSymbol_mk_eq_some (by omega) (by omega))] + exact ih (moveInputPos p .neg) (by rw [val_moveInputPos_neg]; omega) (by omega) + +end Rewind + +/-- **The machine that rewinds the input head.** From any configuration in its initial state it +halts, within `input.length + 3` steps, with the input head at position `1` — the first input +symbol — and with the work tapes, the work-tape head positions and the output unchanged at every +step of the run. Before the halting step the machine is live, so runs chain sequentially. -/ +public theorem exists_rewindInput (k : ℕ) (Symbol : Type*) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), + ∀ (input : List Symbol) (c : Cfg k Symbol State input), c.state = some tm.q₀ → + ∃ u ≤ c.inputPos.val + 2, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, 1, c.workTapes, c.workTapePos, c.output⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).workTapes = c.workTapes ∧ + (tm.runFrom c m).workTapePos = c.workTapePos ∧ + (tm.runFrom c m).output = c.output := by + refine ⟨RewindState, inferInstance, rewindInput k Symbol, fun input c hc => ?_⟩ + obtain ⟨q, p, w, wp, out⟩ := c + obtain rfl : q = some RewindState.probe := hc + -- the run halts at position `1` after at most `input.length + 3` steps + obtain ⟨u₀, hu₀, hrun⟩ : ∃ u₀ ≤ p.val + 2, + (rewindInput k Symbol).runFrom ⟨some .probe, p, w, wp, out⟩ u₀ = + ⟨none, 1, w, wp, out⟩ := by + rcases Nat.eq_zero_or_pos p.val with hp0 | hp1 + · -- started at the left boundary: probe, probe again, halt + refine ⟨2, by omega, ?_⟩ + obtain rfl : p = 0 := Fin.ext (by simpa using hp0) + rw [Rewind.runFrom_two, Rewind.step_probe_none (Rewind.inputSymbol_mk_eq_none_left rfl), + show moveInputPos (0 : Fin (input.length + 2)) .neg = 0 from + Fin.ext (by rw [Rewind.val_moveInputPos_neg]; simp), + Rewind.step_probe2_none (Rewind.inputSymbol_mk_eq_none_left rfl)] + refine Rewind.cfg_congr ?_ + rw [Rewind.val_moveInputPos_pos 0 (by simp)] + simp + rcases Nat.lt_or_ge p.val (input.length + 1) with hplt | hpge + · -- started inside the input: one probe, then walk to the boundary + refine ⟨p.val + 1, by omega, ?_⟩ + have hw := Rewind.runFrom_walk (k := k) (w := w) (wp := wp) (out := out) (p.val - 1) + (moveInputPos p .neg) (by rw [Rewind.val_moveInputPos_neg]) (by omega) + rw [show p.val - 1 + 1 = p.val from by omega] at hw + rw [runFrom_succ_eq_step, + Rewind.step_read _ (Rewind.inputSymbol_mk_eq_some (by omega) (by omega))] + exact hw + · -- started at the right boundary + have hpv : p.val = input.length + 1 := by have := p.isLt; omega + have hs1 := Rewind.inputSymbol_mk_eq_none_right (q := some .probe) (w := w) (wp := wp) + (out := out) hpv + rcases Nat.eq_zero_or_pos input.length with hlen | hlen + · -- empty input: two probes and halt + refine ⟨2, by omega, ?_⟩ + rw [Rewind.runFrom_two, Rewind.step_probe_none hs1, + show moveInputPos p .neg = 0 from + Fin.ext (by rw [Rewind.val_moveInputPos_neg, Fin.val_zero]; omega), + Rewind.step_probe2_none (Rewind.inputSymbol_mk_eq_none_left rfl)] + refine Rewind.cfg_congr ?_ + rw [Rewind.val_moveInputPos_pos 0 (by simp)] + simp + · -- nonempty input: one probe, the second probe finds a symbol, then walk + refine ⟨1 + (1 + (input.length - 1 + 1)), by omega, ?_⟩ + have hmv : (moveInputPos p .neg).val = input.length := by + rw [Rewind.val_moveInputPos_neg]; omega + rw [runFrom_add, Rewind.runFrom_one, Rewind.step_probe_none hs1, + runFrom_add, Rewind.runFrom_one, + Rewind.step_read _ (Rewind.inputSymbol_mk_eq_some (by omega) (by omega))] + exact Rewind.runFrom_walk (input.length - 1) _ + (by rw [Rewind.val_moveInputPos_neg, hmv]) (by omega) + -- take the first halting time; the frame holds at every step + obtain ⟨u, hu, hhalt, hactive⟩ := + exists_minimal_halting_time (rewindInput k Symbol) _ u₀ (by rw [hrun]) + have hfin : (rewindInput k Symbol).runFrom ⟨some RewindState.probe, p, w, wp, out⟩ u = + ⟨none, 1, w, wp, out⟩ := by + have h := runFrom_eq_of_halt (rewindInput k Symbol) _ hu hhalt + rw [hrun] at h + exact h.symm + exact ⟨u, le_trans hu hu₀, hactive, hfin, fun m _ => Rewind.runFrom_frame _ m⟩ + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean new file mode 100644 index 0000000000..be24fb6e5f --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/RewindTape.lean @@ -0,0 +1,334 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.StepLemmas + +/-! +# A machine that rewinds a work-tape head + +A two-state machine that returns the head of one designated work tape `i` to position `0` — the +start of the word — from the frontier just past the word, and halts there. It never writes to any +tape, never moves the input head, never moves any other work head and never outputs, so a +combinator can run it between two phases of a computation to re-normalise a work-tape head without +disturbing anything else. + +Tape `i` holds a word `w` in cells `0, …, w.length - 1` and is blank everywhere else, and the head +starts at the frontier cell `w.length`. In its initial state `start` the machine takes one +unconditional step left, into state `scan`. In state `scan` it walks left over the symbols of `w`; +the first blank it reads is the cell at position `-1`, and the halting transition moves the head +right, back onto position `0`. + +On a word of length `L` the run halts after `L + 2` steps, having read the cells `-1, …, L - 1` of +tape `i` and touched nothing else. + +## Main results + +* `Turing.MultiTapeTM.exists_rewindTape`: the machine that rewinds a work-tape head to the start of + its word. +-/ + +namespace Turing.MultiTapeTM + +variable {K : ℕ} {Symbol : Type*} {input : List Symbol} + +/-- The control states of the work-tape-rewinding machine: `start` takes one unconditional step +left, `scan` walks left towards the start of the word. -/ +inductive RewindTapeState : Type + | start + | scan + +instance : Finite RewindTapeState := + Finite.of_injective + (fun q => match q with + | .start => (0 : Fin 2) + | .scan => 1) + (fun a b h => by cases a <;> cases b <;> first | rfl | exact absurd h (by decide)) + +/-- The work-tape-rewinding machine for tape `i`. In state `start` it moves the head of tape `i` +left, unconditionally, and enters state `scan`. In state `scan` it moves left over a symbol, +staying in `scan`; on the first blank it moves right and halts. No tape is ever written, the input +head never moves, no other work head moves and nothing is output. -/ +def rewindTape (i : Fin K) : MultiTapeTM K Symbol RewindTapeState where + q₀ := .start + tr q _ work := + match q, work i with + | .start, _ => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some .scan } + | .scan, some _ => + { inputTape := 0, workTapes := fun l => (none, if l = i then -1 else 0), + output := none, state := some .scan } + | .scan, none => + { inputTape := 0, workTapes := fun l => (none, if l = i then 1 else 0), + output := none, state := none } + +namespace RewindTape + +variable {i : Fin K} {ip : Fin (input.length + 2)} {W : Fin K → ℤ → Option Symbol} + {WP : Fin K → ℤ} {out : List Symbol} {p : ℤ} + +/-- A configuration of the rewinding machine: state `q`, the head of tape `i` at `p`, every other +field frozen — tape contents `W`, the other heads `WP`, the input head `ip` and output `out`. -/ +def cfg (input : List Symbol) (i : Fin K) (q : Option RewindTapeState) + (ip : Fin (input.length + 2)) (W : Fin K → ℤ → Option Symbol) (WP : Fin K → ℤ) + (out : List Symbol) (p : ℤ) : Cfg K Symbol RewindTapeState input := + ⟨q, ip, W, Function.update WP i p, out⟩ + +/-- Configurations of the shape `cfg` are equal as soon as the tape-`i` head positions agree. -/ +lemma cfg_congr {q : Option RewindTapeState} {p p' : ℤ} (hp : p = p') : + cfg input i q ip W WP out p = cfg input i q ip W WP out p' := by + rw [hp] + +/-- Moving the head of tape `i` left in state `start`, unconditionally, entering `scan`. -/ +lemma step_start : + (rewindTape i).step (cfg input i (some .start) ip W WP out p) = + cfg input i (some .scan) ip W WP out (p - 1) := by + unfold step + simp only [cfg] + simp only [rewindTape] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Walking left in state `scan`: over a symbol the head moves left and stays in `scan`. -/ +lemma step_scan_some {s : Symbol} (hs : W i p = some s) : + (rewindTape i).step (cfg input i (some .scan) ip W WP out p) = + cfg input i (some .scan) ip W WP out (p - 1) := by + have hsym : (cfg input i (some .scan) ip W WP out p).workTapeSymbols i = some s := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [rewindTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp [sub_eq_add_neg] + · simp [h] + · simp + +/-- Halting in state `scan`: on the first blank — the cell at position `-1` — the head moves right +and the machine halts. -/ +lemma step_scan_none (hs : W i p = none) : + (rewindTape i).step (cfg input i (some .scan) ip W WP out p) = + cfg input i none ip W WP out (p + 1) := by + have hsym : (cfg input i (some .scan) ip W WP out p).workTapeSymbols i = none := by + simp [cfg, Cfg.workTapeSymbols, hs] + unfold step + simp only [cfg] at hsym ⊢ + simp only [rewindTape] + rw [hsym] + refine Cfg.ext rfl ?_ ?_ ?_ ?_ + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp + · funext l + rcases eq_or_ne l i with rfl | h + · simp + · simp [h] + · simp + +/-- The scanning phase: from `scan` at the last cell of the word, after `n ≤ w.length` steps the +head has walked left `n` cells, over untouched symbols. -/ +lemma runFrom_scan {w : List Symbol} (hw : W i = tapeOfList w) (n : ℕ) (hn : n ≤ w.length) : + (rewindTape i).runFrom (cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1)) n = + cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1 - n) := by + induction n with + | zero => + rw [runFrom_zero] + exact cfg_congr (by omega) + | succ n ih => + have hpos : (w.length : ℤ) - 1 - n = ((w.length - 1 - n : ℕ) : ℤ) := by omega + have hsym : W i ((w.length : ℤ) - 1 - n) = some (w[w.length - 1 - n]'(by omega)) := by + rw [hw, hpos, tapeOfList_ofNat] + exact List.getElem?_eq_getElem (by omega) + rw [runFrom_succ_eq_step', ih (by omega), step_scan_some hsym] + exact cfg_congr (by omega) + +/-- The complete run: from `start` at the frontier `w.length`, after `w.length + 2` steps the +machine has halted with the head of tape `i` back at position `0`. -/ +lemma runFrom_full {w : List Symbol} (hw : W i = tapeOfList w) : + (rewindTape i).runFrom (cfg input i (some .start) ip W WP out (w.length : ℤ)) (w.length + 2) = + cfg input i none ip W WP out 0 := by + have hstep1 : (rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) 1 = + cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1) := by + rw [runFrom_succ_eq_step', runFrom_zero]; exact step_start + have hscanEnd : (rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) (1 + w.length) = + cfg input i (some .scan) ip W WP out (-1) := by + rw [runFrom_add, hstep1, runFrom_scan hw w.length le_rfl] + exact cfg_congr (by omega) + have hnone : W i (-1 : ℤ) = none := by + rw [hw, show (-1 : ℤ) = Int.negSucc 0 from by omega, tapeOfList_negSucc] + rw [show w.length + 2 = (1 + w.length) + 1 from by omega, runFrom_succ_eq_step', hscanEnd, + step_scan_none hnone] + exact cfg_congr (by omega) + +/-- Throughout the run, the head of tape `i` stays within `[-1, w.length]`: it walks from the +frontier down to `-1` and back to `0`, never leaving that interval. -/ +lemma runFrom_pos_range {w : List Symbol} (hw : W i = tapeOfList w) (m : ℕ) + (hm : m ≤ w.length + 2) : + -1 ≤ ((rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) m).workTapePos i ∧ + ((rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) m).workTapePos i ≤ + (w.length : ℤ) := by + have hstep1 : (rewindTape i).runFrom + (cfg input i (some .start) ip W WP out (w.length : ℤ)) 1 = + cfg input i (some .scan) ip W WP out ((w.length : ℤ) - 1) := by + rw [runFrom_succ_eq_step', runFrom_zero]; exact step_start + rcases Nat.lt_or_ge m 1 with h0 | h1 + · obtain rfl : m = 0 := by omega + rw [runFrom_zero] + constructor <;> simp only [cfg, Function.update_self] <;> omega + rcases Nat.lt_or_ge m (w.length + 2) with hlt | hge + · -- scanning: head at `w.length - m` + obtain ⟨d, hd, rfl⟩ : ∃ d, d ≤ w.length ∧ m = 1 + d := ⟨m - 1, by omega, by omega⟩ + rw [runFrom_add, hstep1, runFrom_scan hw d hd] + constructor <;> simp only [cfg, Function.update_self] <;> omega + · obtain rfl : m = w.length + 2 := by omega + rw [runFrom_full hw] + constructor <;> simp only [cfg, Function.update_self] <;> omega + +/-- No action of the machine writes to a work tape. -/ +lemma tr_write_none (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) + (l : Fin K) : (((rewindTape i).tr q inp work).workTapes l).1 = none := by + simp only [rewindTape] + cases q <;> cases work i <;> rfl + +/-- No action of the machine moves the input head. -/ +lemma tr_inputTape (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((rewindTape i).tr q inp work).inputTape = 0 := by + simp only [rewindTape] + cases q <;> cases work i <;> rfl + +/-- No action of the machine outputs. -/ +lemma tr_output (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) : + ((rewindTape i).tr q inp work).output = none := by + simp only [rewindTape] + cases q <;> cases work i <;> rfl + +/-- No action of the machine moves a work head other than the head of tape `i`. -/ +lemma tr_move_ne (q : RewindTapeState) (inp : Option Symbol) (work : Fin K → Option Symbol) + {l : Fin K} (h : l ≠ i) : (((rewindTape i).tr q inp work).workTapes l).2 = 0 := by + simp only [rewindTape] + cases q <;> cases work i <;> simp [h] + +/-- One step preserves the input head, the output, every tape's contents and every work head other +than the head of tape `i`. -/ +lemma step_frame (c : Cfg K Symbol RewindTapeState input) : + ((rewindTape i).step c).inputPos = c.inputPos ∧ + ((rewindTape i).step c).output = c.output ∧ + (∀ j, ((rewindTape i).step c).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((rewindTape i).step c).workTapePos j = c.workTapePos j) := by + cases hc : c.state with + | none => rw [step_of_halt hc]; exact ⟨rfl, rfl, fun _ => rfl, fun _ _ => rfl⟩ + | some q => + refine ⟨?_, ?_, ?_, ?_⟩ + · rw [step_inputPos_of_state hc, tr_inputTape, moveInputPos_zero] + · rw [step_apply_of_state hc, Action.apply_output, tr_output]; simp + · intro j + rw [step_workTapes_of_state hc, tr_write_none q c.inputSymbol c.workTapeSymbols j] + · intro j hj + rw [step_workTapePos_of_state hc, tr_move_ne q c.inputSymbol c.workTapeSymbols hj] + simp + +/-- The whole run preserves the input head, the output, every tape's contents and every work head +other than the head of tape `i`. -/ +lemma runFrom_frame (c : Cfg K Symbol RewindTapeState input) (m : ℕ) : + ((rewindTape i).runFrom c m).inputPos = c.inputPos ∧ + ((rewindTape i).runFrom c m).output = c.output ∧ + (∀ j, ((rewindTape i).runFrom c m).workTapes j = c.workTapes j) ∧ + (∀ j, j ≠ i → ((rewindTape i).runFrom c m).workTapePos j = c.workTapePos j) := by + induction m with + | zero => exact ⟨rfl, rfl, fun _ => rfl, fun _ _ => rfl⟩ + | succ m ih => + obtain ⟨h1, h2, h3, h4⟩ := step_frame ((rewindTape i).runFrom c m) + rw [runFrom_succ_eq_step'] + exact ⟨h1.trans ih.1, h2.trans ih.2.1, fun j => (h3 j).trans (ih.2.2.1 j), + fun j hj => (h4 j hj).trans (ih.2.2.2 j hj)⟩ + +end RewindTape + +open RewindTape in +/-- **The machine that rewinds a work-tape head.** One machine per tape index `i`: started with +tape `i` holding a word `w` in cells `0, …, w.length - 1` and the head at the frontier `w.length`, +it halts within `w.length + 3` steps with the head back at position `0` and every other field — +input head, output, all tape contents and all other work heads — unchanged at every step of the +run. Before the halting step the machine is live, so runs chain sequentially. -/ +public theorem exists_rewindTape {Symbol : Type*} {K : ℕ} (i : Fin K) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM K Symbol State), + ∀ (input : List Symbol) (c : Cfg K Symbol State input) (w : List Symbol), + c.state = some tm.q₀ → + c.workTapes i = tapeOfList w → + c.workTapePos i = (w.length : ℤ) → + ∃ u ≤ w.length + 3, + (∀ m < u, (tm.runFrom c m).state ≠ none) ∧ + tm.runFrom c u = ⟨none, c.inputPos, c.workTapes, + Function.update c.workTapePos i 0, c.output⟩ ∧ + ∀ m ≤ u, (tm.runFrom c m).inputPos = c.inputPos ∧ (tm.runFrom c m).output = c.output ∧ + (∀ j, j ≠ i → (tm.runFrom c m).workTapes j = c.workTapes j ∧ + (tm.runFrom c m).workTapePos j = c.workTapePos j) ∧ + (tm.runFrom c m).workTapes i = c.workTapes i ∧ + -1 ≤ (tm.runFrom c m).workTapePos i ∧ + (tm.runFrom c m).workTapePos i ≤ (w.length : ℤ) := by + refine ⟨RewindTapeState, inferInstance, rewindTape i, fun input c w hstate hwi hwp => ?_⟩ + obtain ⟨q, ip, W, WP, out⟩ := c + obtain rfl : q = some RewindTapeState.start := hstate + have hwi' : W i = tapeOfList w := hwi + have hwp' : WP i = (w.length : ℤ) := hwp + -- the starting configuration in the shape of the descriptor `cfg` + have hc0 : (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) = + cfg input i (some .start) ip W WP out (w.length : ℤ) := by + refine Cfg.ext rfl rfl rfl ?_ rfl + change WP = Function.update WP i (w.length : ℤ) + rw [← hwp', Function.update_eq_self] + -- the run halts at position `0` after `w.length + 2` steps + obtain ⟨u, hu, hactive, hhalt⟩ : ∃ u ≤ w.length + 2, + (∀ m < u, ((rewindTape i).runFrom + (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) + m).state ≠ none) ∧ + (rewindTape i).runFrom + (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) u = + ⟨none, ip, W, Function.update WP i 0, out⟩ := by + have hrun : (rewindTape i).runFrom + (⟨some RewindTapeState.start, ip, W, WP, out⟩ : Cfg K Symbol RewindTapeState input) + (w.length + 2) = ⟨none, ip, W, Function.update WP i 0, out⟩ := by + rw [hc0, runFrom_full hwi'] + simp only [cfg] + obtain ⟨u, hu, hhaltu, hact⟩ := + exists_minimal_halting_time (rewindTape i) _ (w.length + 2) (by rw [hrun]) + have heq := runFrom_eq_of_halt (rewindTape i) _ hu hhaltu + rw [hrun] at heq + exact ⟨u, hu, hact, heq.symm⟩ + refine ⟨u, by omega, hactive, hhalt, fun m hm => ?_⟩ + obtain ⟨f1, f2, f3, f4⟩ := + runFrom_frame (⟨some RewindTapeState.start, ip, W, WP, out⟩) m + obtain ⟨g1, g2⟩ := runFrom_pos_range (i := i) (input := input) (ip := ip) (W := W) (WP := WP) + (out := out) hwi' m (by omega) + rw [← hc0] at g1 g2 + exact ⟨f1, f2, fun j hj => ⟨f3 j, f4 j hj⟩, f3 i, g1, g2⟩ + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean new file mode 100644 index 0000000000..ebb3daf2ef --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/Sequential.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Plumbing.TransformsTapes + +/-! +# Sequential composition of machines on shared tapes + +`seq tm₀ tm₁` behaves like `tm₀` until `tm₀` would halt, at which point it continues as `tm₁`, +started in its initial state on the tapes as `tm₀` left them. The state space is +`State₀ ⊕ State₁`, and the *halting transition* of the first phase is mapped to the initial state +of the second, so the handoff costs no extra step. + +At the specification level this is `transformsTapes_seq`: transformations compose, with the time +and space bounds adding. The postcondition of `TransformsTapes` is what makes the proof direct: +the first machine halts in a full `wordsCfg`, which is exactly a starting configuration for the +second. + +## Main results + +* `Turing.MultiTapeTM.seq`: the composed machine. +* `Turing.MultiTapeTM.transformsTapes_seq`: transformations compose, bounds adding. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State₀ State₁ : Type*} {input : List Symbol} + +/-- The sequential composition of `tm₀` and `tm₁`: it behaves like `tm₀` until `tm₀` would halt, +at which point it switches to the initial state of `tm₁` and behaves like `tm₁`. The switch is +folded into the halting transition of `tm₀`, so it costs no step. -/ +def seq (tm₀ : MultiTapeTM k Symbol State₀) (tm₁ : MultiTapeTM k Symbol State₁) : + MultiTapeTM k Symbol (State₀ ⊕ State₁) where + q₀ := .inl tm₀.q₀ + tr q inp work := + match q with + | .inl q₀ => + let a := tm₀.tr q₀ inp work + { a with state := some (a.state.elim (.inr tm₁.q₀) .inl) } + | .inr q₁ => + let a := tm₁.tr q₁ inp work + { a with state := a.state.map .inr } + +variable {tm₀ : MultiTapeTM k Symbol State₀} {tm₁ : MultiTapeTM k Symbol State₁} + +namespace Sequential + +/-- A configuration of the first phase: a configuration of `tm₀`, with a halted state mapped to +the initial state of the second phase. Under this map, the whole first phase of `seq` mirrors the +run of `tm₀`, *including* its halting step. -/ +def leftCfg (tm₁ : MultiTapeTM k Symbol State₁) (cfg : Cfg k Symbol State₀ input) : + Cfg k Symbol (State₀ ⊕ State₁) input := + cfg.mapState (fun st => some (st.elim (.inr tm₁.q₀) .inl)) + +/-- A configuration of the second phase. Under this map, the second phase of `seq` mirrors the +run of `tm₁`. -/ +def rightCfg (cfg : Cfg k Symbol State₁ input) : + Cfg k Symbol (State₀ ⊕ State₁) input := + cfg.mapState (Option.map .inr) + +lemma step_leftCfg (cfg : Cfg k Symbol State₀ input) (h : cfg.state ≠ none) : + (tm₀.seq tm₁).step (leftCfg tm₁ cfg) = leftCfg tm₁ (tm₀.step cfg) := by + obtain ⟨q, hq⟩ := Option.ne_none_iff_exists'.mp h + have h1 : (leftCfg tm₁ cfg).state = some (Sum.inl q : State₀ ⊕ State₁) := by + simp [leftCfg, Cfg.mapState, hq] + simp only [step, h1, hq] + rfl + +lemma step_rightCfg (cfg : Cfg k Symbol State₁ input) : + (tm₀.seq tm₁).step (rightCfg cfg) = rightCfg (tm₁.step cfg) := by + cases hq : cfg.state with + | none => + have h1 : (rightCfg (State₀ := State₀) cfg).state = none := by simp [rightCfg, Cfg.mapState, hq] + simp only [step, h1, hq] + | some q => + have h1 : (rightCfg (State₀ := State₀) cfg).state = some (Sum.inr q : State₀ ⊕ State₁) := by + simp [rightCfg, hq] + simp only [step, h1, hq] + rfl + +/-- The second phase of `seq` mirrors the run of `tm₁`. -/ +lemma runFrom_rightCfg (cfg : Cfg k Symbol State₁ input) (n : ℕ) : + (tm₀.seq tm₁).runFrom (rightCfg cfg) n = rightCfg (tm₁.runFrom cfg n) := + runFrom_comm_of_step rightCfg (fun c => step_rightCfg c) cfg n + +/-- While `tm₀` is running, `seq` mirrors it. -/ +lemma runFrom_leftCfg (cfg : Cfg k Symbol State₀ input) (n : ℕ) + (h : ∀ m < n, (tm₀.runFrom cfg m).state ≠ none) : + (tm₀.seq tm₁).runFrom (leftCfg tm₁ cfg) n = leftCfg tm₁ (tm₀.runFrom cfg n) := by + induction n with + | zero => rfl + | succ n ih => + rw [runFrom_succ_eq_step', runFrom_succ_eq_step', ih fun m hm => h m (by omega), + step_leftCfg _ (h n (by omega))] + +@[simp] +lemma leftCfg_wordsCfg (q : State₀) (ws : Fin k → List Symbol) (out : List Symbol) : + leftCfg tm₁ (wordsCfg input (some q) ws out) = + wordsCfg input (some (Sum.inl q : State₀ ⊕ State₁)) ws out := rfl + +@[simp] +lemma rightCfg_wordsCfg (q : Option State₁) (ws : Fin k → List Symbol) (out : List Symbol) : + rightCfg (State₀ := State₀) (wordsCfg input q ws out) = + wordsCfg input (q.map Sum.inr) ws out := rfl + +@[simp] +lemma workTapePos_leftCfg (cfg : Cfg k Symbol State₀ input) : + (leftCfg tm₁ cfg).workTapePos = cfg.workTapePos := rfl + +@[simp] +lemma workTapePos_rightCfg (cfg : Cfg k Symbol State₁ input) : + (rightCfg (State₀ := State₀) cfg).workTapePos = cfg.workTapePos := rfl + +end Sequential + +open Sequential in +/-- **Sequential composition of transformations.** If the postcondition of the first +transformation implies the precondition of the second, the composed machine performs the two +transformations one after the other, with the time and space bounds adding. -/ +theorem transformsTapes_seq + {P₀ P₁ : (input : List Symbol) → (Fin k → List Symbol) → Prop} + {Q₀ Q₁ : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} + {t₀ s₀ t₁ s₁ : ℕ} + (h₀ : TransformsTapes tm₀ P₀ Q₀ t₀ s₀) (h₁ : TransformsTapes tm₁ P₁ Q₁ t₁ s₁) + (hmid : ∀ input ws ws', P₀ input ws → Q₀ input ws ws' → P₁ input ws') : + TransformsTapes (tm₀.seq tm₁) P₀ + (fun input ws ws'' => ∃ ws', Q₀ input ws ws' ∧ Q₁ input ws' ws'') + (t₀ + t₁) (s₀ + s₁) := by + intro input ws out hP₀ + obtain ⟨τ₀, hτ₀, ws', hrun₀, hQ₀, hspace₀⟩ := h₀ input ws out hP₀ + obtain ⟨τ₁, hτ₁, ws'', hrun₁, hQ₁, hspace₁⟩ := h₁ input ws' out (hmid input ws ws' hP₀ hQ₀) + -- the first halting time of the first machine + obtain ⟨u, hu, huhalt, huactive⟩ := exists_minimal_halting_time tm₀ + (wordsCfg input (some tm₀.q₀) ws out) τ₀ (by simp [hrun₀]) + have hu_run : tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) u = + wordsCfg input none ws' out := by + rw [← runFrom_eq_of_halt tm₀ _ hu huhalt, hrun₀] + -- the first phase mirrors the first machine, ending in the handoff configuration + have hleft : ∀ m ≤ u, (tm₀.seq tm₁).runFrom (wordsCfg input (some (tm₀.seq tm₁).q₀) ws out) m + = leftCfg tm₁ (tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) m) := by + intro m hm + have : wordsCfg (State := State₀ ⊕ State₁) input (some (tm₀.seq tm₁).q₀) ws out = + leftCfg tm₁ (wordsCfg input (some tm₀.q₀) ws out) := rfl + rw [this, runFrom_leftCfg _ m fun r hr => + huactive r (by omega)] + -- the handoff configuration is the second machine's start, seen through the right embedding + have hhandoff : leftCfg tm₁ (tm₀.runFrom (wordsCfg input (some tm₀.q₀) ws out) u) = + rightCfg (wordsCfg input (some tm₁.q₀) ws' out) := by + rw [hu_run] + rfl + refine ⟨u + τ₁, by omega, ws'', ?_, ⟨ws', hQ₀, hQ₁⟩, ?_⟩ + · rw [runFrom_add, hleft u le_rfl, hhandoff, runFrom_rightCfg, hrun₁] + rfl + · refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) + · -- the first phase visits what the first machine visits + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u fun m hm => ?_)) + (le_trans (spaceUsed_mono tm₀ _ hu) hspace₀) + rw [hleft m hm, workTapePos_leftCfg] + · -- the second phase visits what the second machine visits + rw [hleft u le_rfl, hhandoff] + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ τ₁ fun m hm => ?_)) hspace₁ + rw [runFrom_rightCfg, workTapePos_rightCfg] + +section RawSeq + +variable {K : ℕ} {Sym S₁ S₂ : Type*} {inp : List Sym} + +open Sequential in +lemma seq_spec {tm₁ : MultiTapeTM K Sym S₁} {tm₂ : MultiTapeTM K Sym S₂} + {c : Cfg K Sym (S₁ ⊕ S₂) inp} {c₁ : Cfg K Sym S₁ inp} {c₂ : Cfg K Sym S₂ inp} + {u₁ u₂ s₁' s₂' : ℕ} + (hc : c.state = some (tm₁.seq tm₂).q₀) + (h₁ : tm₁.runFrom (c.withState (some tm₁.q₀)) u₁ = c₁) + (h₁halt : c₁.state = none) + (h₁act : ∀ m < u₁, (tm₁.runFrom (c.withState (some tm₁.q₀)) m).state ≠ none) + (h₁sp : tm₁.spaceUsed (c.withState (some tm₁.q₀)) u₁ ≤ s₁') + (h₂ : tm₂.runFrom (c₁.withState (some tm₂.q₀)) u₂ = c₂) + (h₂halt : c₂.state = none) + (h₂act : ∀ m < u₂, (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m).state ≠ none) + (h₂sp : tm₂.spaceUsed (c₁.withState (some tm₂.q₀)) u₂ ≤ s₂') : + (tm₁.seq tm₂).runFrom c (u₁ + u₂) = c₂.withState (none : Option (S₁ ⊕ S₂)) ∧ + (∀ m < u₁ + u₂, ((tm₁.seq tm₂).runFrom c m).state ≠ none) ∧ + (tm₁.seq tm₂).spaceUsed c (u₁ + u₂) ≤ s₁' + s₂' := by + set cs := c.withState (some tm₁.q₀) with hcs + have hcleft : c = leftCfg tm₂ cs := by + refine Cfg.ext ?_ rfl rfl rfl rfl + rw [hc] + rfl + have hhalt₁ : (tm₁.runFrom cs u₁).state = none := by rw [h₁]; exact h₁halt + have hleft : ∀ m ≤ u₁, (tm₁.seq tm₂).runFrom c m = leftCfg tm₂ (tm₁.runFrom cs m) := by + intro m hm + rw [hcleft, runFrom_leftCfg _ m fun r hr => h₁act r (by omega)] + have hmid : (tm₁.seq tm₂).runFrom c u₁ = rightCfg (c₁.withState (some tm₂.q₀)) := by + rw [hleft u₁ le_rfl, h₁] + refine Cfg.ext ?_ rfl rfl rfl rfl + simp [leftCfg, rightCfg, Cfg.mapState, Cfg.withState, h₁halt] + have hright : ∀ m, (tm₁.seq tm₂).runFrom c (u₁ + m) = + rightCfg (tm₂.runFrom (c₁.withState (some tm₂.q₀)) m) := by + intro m + rw [runFrom_add, hmid, runFrom_rightCfg] + refine ⟨?_, ?_, ?_⟩ + · rw [hright u₂, h₂] + refine Cfg.ext ?_ rfl rfl rfl rfl + simp [rightCfg, Cfg.withState, h₂halt] + · intro m hm + rcases Nat.le_total m u₁ with h | h + · rw [hleft m h] + simp [leftCfg] + · obtain ⟨m', rfl⟩ : ∃ m', m = u₁ + m' := ⟨m - u₁, by omega⟩ + rw [hright m'] + have h := h₂act m' (by omega) + simpa only [rightCfg, Cfg.mapState_state, ne_eq, Option.map_eq_none_iff] using h + · refine le_trans (spaceUsed_add_le _ _ _) (Nat.add_le_add ?_ ?_) + · refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₁ fun m hm => ?_)) h₁sp + rw [hleft m hm] + rfl + · rw [hmid] + refine le_trans (le_of_eq (spaceUsed_eq_of_workTapePos _ _ u₂ fun m hm => ?_)) h₂sp + rw [runFrom_rightCfg] + rfl + +end RawSeq + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean new file mode 100644 index 0000000000..f7e2e4a166 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/StepLemmas.lean @@ -0,0 +1,87 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic + +/-! +# Reducing one step of an explicit machine + +Every explicit-machine proof — `Copy`, `Clear`, `Rewind`, `Sweep`, `instrument`, the redirections — +computes `tm.step cfg` for a configuration in a known state `some q` and reads off the fields of +the result. The `Action.apply_*` projections here are `@[simp]`, so a caller reduces a step with +`simp [step, hq, ]` without having to name `Action.apply` and without the projection +debris in the fields it does not care about; `step_apply_of_state hq` turns `step` at a live state +into an `Action.apply` for a one-field rewrite, leaving the transition `tm.tr q _ _` folded until +the caller computes it. + +For head-position goals over the boundary-clamping input head, `Turing.val_moveInputPos_eq` gives +the post-move position as an `omega`-native clamped integer, so `simp only [val_moveInputPos_eq, +min_def, max_def]; split_ifs <;> omega` closes them (`SignType` casts to `ℤ` are already +`simp`-reducible in Mathlib). The redirection machines are the customers. +-/ + +public section + +namespace Turing + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +@[simp] public lemma Action.apply_state (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) : (a.apply cfg).state = a.state := rfl + +@[simp] public lemma Action.apply_inputPos (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) : + (a.apply cfg).inputPos = moveInputPos cfg.inputPos a.inputTape := rfl + +@[simp] public lemma Action.apply_output (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) : + (a.apply cfg).output = cfg.output ++ a.output.toList := rfl + +@[simp] public lemma Action.apply_workTapePos (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) (i : Fin k) : + (a.apply cfg).workTapePos i = cfg.workTapePos i + (a.workTapes i).2 := rfl + +public lemma Action.apply_workTapes (a : Action k Symbol State) + (cfg : Cfg k Symbol State input) (i : Fin k) : + (a.apply cfg).workTapes i = match (a.workTapes i).1 with + | none => cfg.workTapes i + | some s => Function.update (cfg.workTapes i) (cfg.workTapePos i) s := rfl + +namespace MultiTapeTM + +variable {tm : MultiTapeTM k Symbol State} {cfg : Cfg k Symbol State input} {q : State} + +/-- One step at a live state is the transition's action applied to the configuration. This is the +form `simp only [step_apply_of_state hq]` uses to reduce a whole step. -/ +public lemma step_apply_of_state (h : cfg.state = some q) : + tm.step cfg = (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).apply cfg := by + rw [step, h] + +/-- The input head after a live step. -/ +public lemma step_inputPos_of_state (h : cfg.state = some q) : + (tm.step cfg).inputPos = + moveInputPos cfg.inputPos (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).inputTape := by + rw [step_apply_of_state h, Action.apply_inputPos] + +/-- A work tape after a live step. -/ +public lemma step_workTapes_of_state (h : cfg.state = some q) (i : Fin k) : + (tm.step cfg).workTapes i = + match (tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workTapes i |>.1 with + | none => cfg.workTapes i + | some s => Function.update (cfg.workTapes i) (cfg.workTapePos i) s := by + rw [step_apply_of_state h, Action.apply_workTapes] + +/-- A work tape head after a live step. -/ +public lemma step_workTapePos_of_state (h : cfg.state = some q) (i : Fin k) : + (tm.step cfg).workTapePos i = + cfg.workTapePos i + ((tm.tr q cfg.inputSymbol cfg.workTapeSymbols).workTapes i).2 := by + rw [step_apply_of_state h, Action.apply_workTapePos] + +end MultiTapeTM + +end Turing diff --git a/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean new file mode 100644 index 0000000000..4dcba97bf0 --- /dev/null +++ b/Cslib/Computability/Machines/Turing/MultiTape/Plumbing/TransformsTapes.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Christian Reitwiessner and Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner, Samuel Schlesinger +-/ + +module + +public import Cslib.Computability.Machines.Turing.MultiTape.TapeLemmas + +/-! +# Machines as transformers of tape words + +The interface through which combinators use machines: a machine reads words from its work tapes +and leaves words on them. A combinator composing such machines talks about words only, never about +individual cells, head positions or the set of tapes a machine has touched. + +Configurations are described by *equalities*: `wordsCfg input q ws out` is the configuration whose +work tape `i` holds exactly the word `ws i` (contents `tapeOfList (ws i)`, head at the start), with +the input head at the start of the input and output `out`. A specification +`TransformsTapes tm P Q t s` says: started on word-holding tapes satisfying `P`, the machine halts +within `t` steps in the *normal form* `wordsCfg input none ws' out` (every head reset to its +initial position, tapes blank outside their words, output untouched), with the new words related to +the old ones by `Q` and using at most `s` work-tape cells. Requiring this normal form is what lets +specifications compose by rewriting: the halting configuration of one machine is already a valid +start for the next, so which words survived a step is read off the equation, not re-established cell +by cell. + +## Main definitions + +* `Turing.MultiTapeTM.tapeOfList`: the tape holding exactly a given word. +* `Turing.MultiTapeTM.wordsCfg`: the configuration whose tapes hold given words. +* `Turing.MultiTapeTM.TransformsTapes`: the specification format described above. + +## Main results + +* `Turing.MultiTapeTM.TransformsTapes.imp`: strengthen the precondition, weaken the postcondition + and raise the bounds. +* `Turing.MultiTapeTM.exists_transformsTapes_nop`: the machine that does nothing, the first + machine of the interface and the check that the format is inhabited as intended. +-/ + +@[expose] public section + +namespace Turing.MultiTapeTM + +variable {k : ℕ} {Symbol State : Type*} {input : List Symbol} + +/-- A tape containing exactly the symbols of `xs` at positions `0, ..., xs.length - 1`. -/ +def tapeOfList (xs : List Symbol) : ℤ → Option Symbol + | .ofNat n => xs[n]? + | .negSucc _ => none + +@[simp] +lemma tapeOfList_ofNat (xs : List Symbol) (n : ℕ) : tapeOfList xs n = xs[n]? := rfl + +@[simp] +lemma tapeOfList_negSucc (xs : List Symbol) (n : ℕ) : + tapeOfList xs (.negSucc n) = none := rfl + +/-- Appending one symbol writes precisely the cell after the existing word. -/ +lemma tapeOfList_append_single (xs : List Symbol) (x : Symbol) : + tapeOfList (xs ++ [x]) = Function.update (tapeOfList xs) (xs.length : ℤ) (some x) := by + funext z + cases z with + | negSucc n => simp [tapeOfList] + | ofNat n => grind [tapeOfList] + +/-- The blank tape holds the empty word. -/ +@[simp] +lemma tapeOfList_nil : tapeOfList ([] : List Symbol) = fun _ => none := by + funext z + cases z <;> simp + +/-- The cell at position `0` holds the first symbol of the word. -/ +lemma tapeOfList_zero (xs : List Symbol) : tapeOfList xs 0 = xs.head? := by + have h : (0 : ℤ) = ((0 : ℕ) : ℤ) := rfl + rw [h, tapeOfList_ofNat] + cases xs <;> rfl + +/-- The configuration whose work tape `i` holds exactly the word `ws i` with its head at the +start, whose input head is at the start of the input, in state `q` with output `out`. -/ +@[simps] +def wordsCfg (input : List Symbol) (q : Option State) + (ws : Fin k → List Symbol) (out : List Symbol) : Cfg k Symbol State input := + ⟨q, 1, fun i => tapeOfList (ws i), fun _ => 0, out⟩ + +/-- Remapping the state of a `wordsCfg` remaps its state and leaves the words alone. -/ +@[simp] +lemma mapState_wordsCfg {State' : Type*} (φ : Option State → Option State') + (input : List Symbol) (q : Option State) (ws : Fin k → List Symbol) (out : List Symbol) : + (wordsCfg input q ws out).mapState φ = wordsCfg input (φ q) ws out := rfl + +/-- The initial configuration is the word configuration with blank tapes and no output. -/ +lemma initCfg_eq_wordsCfg (tm : MultiTapeTM k Symbol State) (input : List Symbol) : + tm.initCfg input = wordsCfg input (some tm.q₀) (fun _ => []) [] := by + refine Cfg.ext rfl rfl ?_ rfl rfl + funext i + simp [Cfg.init, wordsCfg] + +/-- `TransformsTapes tm P Q t s`: started in its initial state on tapes holding words `ws` that +satisfy the precondition `P`, the machine halts after at most `t` steps in the configuration whose +tapes hold words `ws'` with `Q input ws ws'`, having used at most `s` work-tape cells. + +The bounds are numbers; a specification whose bounds depend on the data is a *family* +`∀ j, TransformsTapes tm (P j) (Q j) (t j) (s j)` over one fixed machine. -/ +def TransformsTapes (tm : MultiTapeTM k Symbol State) + (P : (input : List Symbol) → (Fin k → List Symbol) → Prop) + (Q : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop) + (t s : ℕ) : Prop := + ∀ (input : List Symbol) (ws : Fin k → List Symbol) (out : List Symbol), P input ws → + ∃ τ ≤ t, ∃ ws', + tm.runFrom (wordsCfg input (some tm.q₀) ws out) τ = wordsCfg input none ws' out ∧ + Q input ws ws' ∧ + tm.spaceUsed (wordsCfg input (some tm.q₀) ws out) τ ≤ s + +/-- A `TransformsTapes` statement can be read with a stronger precondition, a weaker postcondition +and larger bounds. -/ +theorem TransformsTapes.imp {tm : MultiTapeTM k Symbol State} + {P P' : (input : List Symbol) → (Fin k → List Symbol) → Prop} + {Q Q' : (input : List Symbol) → (Fin k → List Symbol) → (Fin k → List Symbol) → Prop} + {t s t' s' : ℕ} (h : TransformsTapes tm P Q t s) + (hP : ∀ input ws, P' input ws → P input ws) + (hQ : ∀ input ws ws', P' input ws → Q input ws ws' → Q' input ws ws') + (ht : t ≤ t') (hs : s ≤ s') : + TransformsTapes tm P' Q' t' s' := by + intro input ws out hP' + obtain ⟨τ, hτ, ws', hrun, hQ', hspace⟩ := h input ws out (hP input ws hP') + exact ⟨τ, hτ.trans ht, ws', hrun, hQ input ws ws' hP' hQ', hspace.trans hs⟩ + +section Nop + +/-- The machine that does nothing: it halts on its first step, leaving the configuration +unchanged. -/ +private def nop (k : ℕ) (Symbol : Type*) : MultiTapeTM k Symbol Unit where + q₀ := () + tr _ _ _ := { inputTape := 0, workTapes := fun _ => (none, 0), output := none, state := none } + +private lemma step_nop (ws : Fin k → List Symbol) (out : List Symbol) : + (nop k Symbol).step (wordsCfg input (some ()) ws out) = wordsCfg input none ws out := by + refine Cfg.ext rfl ?_ ?_ ?_ ?_ <;> + simp [step, nop, Action.apply, wordsCfg, SignType.cast] + +/-- The machine that does nothing: it halts in one step, leaving every word as it was. Its +heads never move, so it visits one cell per tape. This is the first machine of the interface: it +checks that the specification format is inhabited exactly as intended. -/ +theorem exists_transformsTapes_nop (k : ℕ) (Symbol : Type*) : + ∃ (State : Type) (_ : Finite State) (tm : MultiTapeTM k Symbol State), + TransformsTapes tm (fun _ _ => True) (fun _ ws ws' => ws' = ws) 1 k := by + refine ⟨Unit, inferInstance, nop k Symbol, fun input ws out _ => ?_⟩ + have hrun : (nop k Symbol).runFrom (wordsCfg input (some ()) ws out) 1 = + wordsCfg input none ws out := by + rw [runFrom_succ_eq_step', runFrom_zero, step_nop] + -- the heads never move, so each tape touches only the single cell `0` + refine ⟨1, le_rfl, ws, hrun, rfl, spaceUsed_le_of_workTapePos_const _ 1 fun m hm => ?_⟩ + rcases (by omega : m = 0 ∨ m = 1) with rfl | rfl + · rw [runFrom_zero] + · rw [hrun]; funext i; simp only [wordsCfg_workTapePos] + +end Nop + +end Turing.MultiTapeTM diff --git a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean index b6a2574d38..a737610d6f 100644 --- a/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean +++ b/Cslib/Computability/Machines/Turing/MultiTape/TapeLemmas.lean @@ -8,6 +8,7 @@ module public import Cslib.Computability.Machines.Turing.MultiTape.Deterministic public import Mathlib.Data.Int.Interval +public import Mathlib.Order.Lattice.Nat /-! # Tape head visitation and space-usage lemmas @@ -17,6 +18,10 @@ This file collects lemmas about the set of positions visited by a work-tape head (`MultiTapeTM.spaceUsedByTape`, `MultiTapeTM.spaceUsed`) and how the tape head positions influence the cells that are modified on a tape. +`MultiTapeTM.exists_spaceUsedByTape_max` shows that a computation whose space usage is bounded +attains its per-tape space usage at a single step, which makes a bound that holds at every point +in time usable as a bound for the whole run. + -/ @[expose] public section @@ -148,4 +153,180 @@ lemma spaceUsed_mono (tm : MultiTapeTM k Symbol State) (cfg : Cfg k Symbol State intro t t' h exact Finset.sum_le_sum (fun i _ => spaceUsedByTape_mono tm cfg i h) +/-- A computation whose total space usage stays below a bound reaches a step `T` at which the space +usage of *every* tape is maximal. This turns a bound that holds at every point in time into a +bound for the whole run. -/ +lemma exists_spaceUsedByTape_max (cfg : Cfg k Symbol State input) {s : ℕ} + (hs : ∀ t, tm.spaceUsed cfg t ≤ s) : + ∃ T, ∀ t i, tm.spaceUsedByTape cfg t i ≤ tm.spaceUsedByTape cfg T i := by + -- The space usage of a single tape is bounded, so it attains its supremum at some step `T i`. + have h : ∀ i, ∃ Ti, ∀ t, tm.spaceUsedByTape cfg t i ≤ tm.spaceUsedByTape cfg Ti i := by + intro i + have hbdd : BddAbove (Set.range (tm.spaceUsedByTape cfg · i)) := + ⟨s, by rintro _ ⟨t, rfl⟩; exact (tm.spaceUsedByTape_le_spaceUsed cfg t i).trans (hs t)⟩ + obtain ⟨Ti, hTi⟩ := Nat.sSup_mem (Set.range_nonempty (tm.spaceUsedByTape cfg · i)) hbdd + exact ⟨Ti, fun t => (le_csSup hbdd ⟨t, rfl⟩).trans hTi.ge⟩ + choose T hT using h + -- Monotonicity lets us use a single step that is late enough for every tape. + exact ⟨Finset.univ.sup T, fun t i => + (hT i t).trans (tm.spaceUsedByTape_mono cfg i (Finset.le_sup (Finset.mem_univ i)))⟩ + + +/-- Every position the head takes up to step `t` lies in `S`, so the whole visited set does. This +is `Finset.image_subset_iff` for the visited set, and the workhorse behind the space bounds +below. -/ +lemma visitedByTapeHead_subset (cfg : Cfg k Symbol State input) {t : ℕ} {i : Fin k} {S : Finset ℤ} + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos i ∈ S) : + tm.visitedByTapeHead cfg t i ⊆ S := + Finset.image_subset_iff.mpr fun m hm => h m (Nat.lt_succ_iff.mp (Finset.mem_range.mp hm)) + +/-- A set containing every position of a head bounds the space used by its tape. -/ +lemma spaceUsedByTape_le_card (cfg : Cfg k Symbol State input) {t : ℕ} {i : Fin k} {S : Finset ℤ} + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos i ∈ S) : + tm.spaceUsedByTape cfg t i ≤ S.card := + Finset.card_le_card (tm.visitedByTapeHead_subset cfg h) + +/-- A head that never moves uses a single cell. -/ +lemma spaceUsedByTape_le_one (cfg : Cfg k Symbol State input) {t : ℕ} {i : Fin k} + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos i = cfg.workTapePos i) : + tm.spaceUsedByTape cfg t i ≤ 1 := by + simpa using tm.spaceUsedByTape_le_card cfg (S := {cfg.workTapePos i}) + fun m hm => by simp [h m hm] + +/-- The cells a run visits are the ones visited by its two halves. -/ +lemma visitedByTapeHead_add (cfg : Cfg k Symbol State input) (a b : ℕ) (i : Fin k) : + tm.visitedByTapeHead cfg (a + b) i = + tm.visitedByTapeHead cfg a i ∪ tm.visitedByTapeHead (tm.runFrom cfg a) b i := by + ext z + simp only [mem_visitedByTapeHead, Finset.mem_union] + constructor + · rintro ⟨r, hr, rfl⟩ + rcases Nat.lt_or_ge r (a + 1) with h | h + · exact Or.inl ⟨r, h, rfl⟩ + · exact Or.inr ⟨r - a, by omega, + by rw [← runFrom_add, show a + (r - a) = r from by omega]⟩ + · rintro (⟨r, hr, rfl⟩ | ⟨r, hr, rfl⟩) + · exact ⟨r, by omega, rfl⟩ + · exact ⟨a + r, by omega, by rw [runFrom_add]⟩ + +/-- Splitting a run into two phases can only overcount the cells it visits, since the two phases +may revisit each other's cells. -/ +lemma spaceUsed_add_le (cfg : Cfg k Symbol State input) (a b : ℕ) : + tm.spaceUsed cfg (a + b) ≤ tm.spaceUsed cfg a + tm.spaceUsed (tm.runFrom cfg a) b := by + rw [spaceUsed, spaceUsed, spaceUsed, ← Finset.sum_add_distrib] + refine Finset.sum_le_sum fun i _ => ?_ + rw [spaceUsedByTape, visitedByTapeHead_add] + exact Finset.card_union_le _ _ + +/-- Space usage only depends on where the work-tape heads are at each step, so two runs whose head +positions agree use the same space. This is what lets a machine be replaced by a simulation of +it. -/ +lemma spaceUsed_eq_of_workTapePos {State' : Type*} {input' : List Symbol} + {tm' : MultiTapeTM k Symbol State'} (cfg : Cfg k Symbol State input) + (cfg' : Cfg k Symbol State' input') (t : ℕ) + (h : ∀ m ≤ t, (tm.runFrom cfg m).workTapePos = (tm'.runFrom cfg' m).workTapePos) : + tm.spaceUsed cfg t = tm'.spaceUsed cfg' t := by + refine Finset.sum_congr rfl fun i _ => congrArg Finset.card (Finset.image_congr fun m hm => ?_) + exact congrFun (h m (Nat.lt_succ_iff.mp (Finset.mem_range.mp hm))) i + +/-- The cells a head visits between two moments of one run all lie in the visited set. -/ +lemma uIcc_workTapePos_subset_visitedByTapeHead_of_le (cfg : Cfg k Symbol State input) + (i : Fin k) {t₁ t₂ t : ℕ} (h₁ : t₁ ≤ t₂) (h₂ : t₂ ≤ t) : + Finset.uIcc ((tm.runFrom cfg t₁).workTapePos i) ((tm.runFrom cfg t₂).workTapePos i) + ⊆ tm.visitedByTapeHead cfg t i := by + intro z hz + have h := tm.uIcc_workTapePos_subset_visitedByTapeHead (tm.runFrom cfg t₁) i (t₂ - t₁) + rw [← runFrom_add, show t₁ + (t₂ - t₁) = t₂ from by omega] at h + have hsub : tm.visitedByTapeHead (tm.runFrom cfg t₁) (t₂ - t₁) i + ⊆ tm.visitedByTapeHead cfg t i := by + intro y hy + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hy + rw [← runFrom_add] + exact mem_visitedByTapeHead.mpr ⟨t₁ + m, by omega, rfl⟩ + exact hsub (h hz) + +/-- A head's visited set is an interval. -/ +lemma exists_visitedByTapeHead_eq_Icc (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) : + ∃ l r : ℤ, l ≤ cfg.workTapePos i ∧ cfg.workTapePos i ≤ r ∧ + tm.visitedByTapeHead cfg t i = Finset.Icc l r := by + have hne : (tm.visitedByTapeHead cfg t i).Nonempty := + ⟨cfg.workTapePos i, mem_visitedByTapeHead.mpr ⟨0, by omega, rfl⟩⟩ + have hmem : cfg.workTapePos i ∈ tm.visitedByTapeHead cfg t i := + mem_visitedByTapeHead.mpr ⟨0, by omega, rfl⟩ + refine ⟨(tm.visitedByTapeHead cfg t i).min' hne, (tm.visitedByTapeHead cfg t i).max' hne, + Finset.min'_le _ _ hmem, Finset.le_max' _ _ hmem, ?_⟩ + apply Finset.Subset.antisymm + · intro z hz + exact Finset.mem_Icc.mpr ⟨Finset.min'_le _ _ hz, Finset.le_max' _ _ hz⟩ + · intro z hz + obtain ⟨t₁, ht₁, hpos₁⟩ := mem_visitedByTapeHead.mp (Finset.min'_mem _ hne) + obtain ⟨t₂, ht₂, hpos₂⟩ := mem_visitedByTapeHead.mp (Finset.max'_mem _ hne) + have hzu : z ∈ Finset.uIcc ((tm.runFrom cfg t₁).workTapePos i) + ((tm.runFrom cfg t₂).workTapePos i) := by + rw [hpos₁, hpos₂, Finset.uIcc_of_le (Finset.min'_le _ _ (Finset.max'_mem _ hne))] + exact hz + rcases Nat.le_total t₁ t₂ with h | h + · exact tm.uIcc_workTapePos_subset_visitedByTapeHead_of_le cfg i h (by omega) hzu + · rw [Finset.uIcc_comm] at hzu + exact tm.uIcc_workTapePos_subset_visitedByTapeHead_of_le cfg i h (by omega) hzu + +/-- After the machine has halted the heads no longer move, so the visited set stops growing. -/ +lemma visitedByTapeHead_eq_of_halt (cfg : Cfg k Symbol State input) {τ t : ℕ} (hle : τ ≤ t) + (hhalt : (tm.runFrom cfg τ).state = none) (i : Fin k) : + tm.visitedByTapeHead cfg t i = tm.visitedByTapeHead cfg τ i := by + refine Finset.Subset.antisymm (visitedByTapeHead_subset cfg fun m hm => ?_) + (tm.visitedByTapeHead_mono cfg i hle) + rcases Nat.le_total m τ with h | h + · exact mem_visitedByTapeHead.mpr ⟨m, by omega, rfl⟩ + · rw [runFrom_eq_of_halt tm cfg h hhalt] + exact tm.mem_visitedByTapeHead_self cfg τ i + +/-- After the machine has halted the heads no longer move, so the space usage stops growing. -/ +lemma spaceUsed_eq_of_halt (cfg : Cfg k Symbol State input) {τ t : ℕ} (hle : τ ≤ t) + (hhalt : (tm.runFrom cfg τ).state = none) : + tm.spaceUsed cfg t = tm.spaceUsed cfg τ := + Finset.sum_congr rfl fun i _ => + congrArg Finset.card (tm.visitedByTapeHead_eq_of_halt cfg hle hhalt i) + +/-- A run that never moves a work-tape head visits one cell per tape. -/ +lemma spaceUsed_le_of_workTapePos_const (cfg : Cfg k Symbol State input) (u : ℕ) + (h : ∀ m ≤ u, (tm.runFrom cfg m).workTapePos = cfg.workTapePos) : + tm.spaceUsed cfg u ≤ k := by + have hcard : ∀ i ∈ Finset.univ, tm.spaceUsedByTape cfg u i ≤ 1 := + fun i _ => tm.spaceUsedByTape_le_one cfg fun m hm => congrFun (h m hm) i + simpa [spaceUsed] using Finset.sum_le_card_nsmul _ _ 1 hcard + +/-- Space bound when one head moves inside an interval and all other heads stay fixed. -/ +lemma spaceUsed_le_of_one_moving (cfg : Cfg k Symbol State input) (t : ℕ) (i : Fin k) + (lo hi : ℤ) + (hi_move : ∀ m ≤ t, lo ≤ (tm.runFrom cfg m).workTapePos i ∧ + (tm.runFrom cfg m).workTapePos i ≤ hi) + (hfixed : ∀ m ≤ t, ∀ j, j ≠ i → (tm.runFrom cfg m).workTapePos j = cfg.workTapePos j) : + tm.spaceUsed cfg t ≤ (hi + 1 - lo).toNat + k := by + have hi_tape : tm.spaceUsedByTape cfg t i ≤ (hi + 1 - lo).toNat := by + refine le_trans (Finset.card_le_card ?_) (le_of_eq (Int.card_Icc lo hi)) + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + exact Finset.mem_Icc.mpr (hi_move m (by omega)) + have hj_tape : ∀ j ∈ Finset.univ.erase i, tm.spaceUsedByTape cfg t j ≤ 1 := by + intro j hj + have hji : j ≠ i := Finset.ne_of_mem_erase hj + refine le_trans (Finset.card_le_card ?_) (le_of_eq (Finset.card_singleton + (cfg.workTapePos j))) + intro z hz + obtain ⟨m, hm, rfl⟩ := mem_visitedByTapeHead.mp hz + rw [hfixed m (by omega) j hji] + exact Finset.mem_singleton_self _ + calc tm.spaceUsed cfg t + = tm.spaceUsedByTape cfg t i + + ∑ j ∈ Finset.univ.erase i, tm.spaceUsedByTape cfg t j := + (Finset.add_sum_erase _ _ (Finset.mem_univ i)).symm + _ ≤ (hi + 1 - lo).toNat + ∑ _j ∈ Finset.univ.erase i, 1 := + Nat.add_le_add hi_tape (Finset.sum_le_sum hj_tape) + _ ≤ (hi + 1 - lo).toNat + k := by + rw [← Finset.card_eq_sum_ones, Finset.card_erase_of_mem (Finset.mem_univ i), + Finset.card_univ, Fintype.card_fin] + omega + + end Turing.MultiTapeTM diff --git a/Cslib/Foundations/Control/Monad/Free.lean b/Cslib/Foundations/Control/Monad/Free.lean index 09d550b8bc..74dea4913c 100644 --- a/Cslib/Foundations/Control/Monad/Free.lean +++ b/Cslib/Foundations/Control/Monad/Free.lean @@ -7,6 +7,7 @@ Authors: Tanner Duve, Eric Wieser module public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom /-! # Free Monad @@ -243,29 +244,44 @@ lemma liftM_bind [LawfulMonad m] | pure a => simp only [liftM_pure, LawfulMonad.pure_bind] | lift_bind op cont ih => simp [← ih] +/-- A morphism of monads moves inside `FreeM.liftM`. -/ +theorem _root_.Cslib.IsMonadHom.map_freeMLiftM [Monad n] + {f : ∀ {α}, m α → n α} (hf : IsMonadHom m n f) + (interp : {ι : Type u} → F ι → m ι) (x : FreeM F α) : + f (x.liftM interp) = x.liftM (fun op => f (interp op)) := by + induction x with + | pure a => exact hf.map_pure a + | lift_bind op cont ih => + simp only [bind_eq_bind, liftM_lift_bind, hf.map_bind, ih] + +/-- `FreeM.liftM interp` is a morphism of monads. -/ +theorem isMonadHom_liftM [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) : + IsMonadHom (FreeM F) m (FreeM.liftM interp) := + IsMonadHom.mk' (liftM_pure interp) (liftM_bind interp) + @[simp] lemma liftM_map [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (f : α → β) (x : FreeM F α) : - (f <$> x).liftM interp = f <$> x.liftM interp := by - simp_rw [← LawfulMonad.bind_pure_comp, liftM_bind, liftM_pure] + (f <$> x).liftM interp = f <$> x.liftM interp := + isMonadHom_liftM interp |>.map_map _ _ @[simp] lemma liftM_seq [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (x : FreeM F (α → β)) (y : FreeM F α) : - (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := by - simp [seq_eq_bind_map] + (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := + isMonadHom_liftM interp |>.map_seq _ _ @[simp] lemma liftM_seqLeft [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (x : FreeM F α) (y : FreeM F β) : - (x <* y).liftM interp = x.liftM interp <* y.liftM interp := by - simp [seqLeft_eq_bind] + (x <* y).liftM interp = x.liftM interp <* y.liftM interp := + isMonadHom_liftM interp |>.map_seqLeft _ _ @[simp] lemma liftM_seqRight [LawfulMonad m] (interp : {ι : Type u} → F ι → m ι) (x : FreeM F α) (y : FreeM F β) : - (x *> y).liftM interp = x.liftM interp *> y.liftM interp := by - simp [seqRight_eq_bind] + (x *> y).liftM interp = x.liftM interp *> y.liftM interp := + isMonadHom_liftM interp |>.map_seqRight _ _ /-- A predicate stating that `interp : FreeM F α → m α` is an interpreter for the effect diff --git a/Cslib/Foundations/Control/Monad/IsMonadHom.lean b/Cslib/Foundations/Control/Monad/IsMonadHom.lean new file mode 100644 index 0000000000..a515d1a408 --- /dev/null +++ b/Cslib/Foundations/Control/Monad/IsMonadHom.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 Eric Wieser. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Eric Wieser +-/ +module + +public import Cslib.Init + +public import Batteries.Control.AlternativeMonad +public import Std.Do.WP.Monad + +/-! +# (unbundled) morphisms of monads + +This file defines predicates on functions `f : ∀ {α}, m α → n α` that preserve functor, applicative, +monadic, and alternative structure (`IsFunctorHom`, `IsApplicativeHom`, `IsMonadHom`, +`IsAlternativeHom`, `IsAlternativeMonadHom`). + +Rather than assuming lawfulness, they explicitly require compatibility with every operator +defined by the corresponding typeclasses, with helper constructors that dismiss the derived +operators when the structures are lawful. +-/ + +public section + +namespace Cslib + +/-! ### Functor Homomorphisms -/ + +/-- +A function `f` is a morphism of functors if it preserves `<$>` and `Functor.mapConst`. +-/ +structure IsFunctorHom (m n) [Functor m] [Functor n] (f : ∀ {α}, m α → n α) : Prop where + map_map {α β} (g : α → β) (x : m α) : f (g <$> x) = g <$> f x + map_mapConst {α β} (a : α) (x : m β) : f (Functor.mapConst a x) = Functor.mapConst a (f x) + +namespace IsFunctorHom +variable {m n p : Type _ → Type _} [Functor m] [Functor n] [Functor p] + +attribute [grind .] map_map map_mapConst + +private theorem map_mapConst_of_map_map + [LawfulFunctor m] [LawfulFunctor n] (f : ∀ {α}, m α → n α) + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) : + ∀ {α β} (a : α) (x : m β), f (Functor.mapConst a x) = Functor.mapConst a (f x) := by + intros α β a x + simp [LawfulFunctor.map_const, map_map] + +/-- Construct an `IsFunctorHom` for lawful functors from `map_map`. -/ +theorem mk' [LawfulFunctor m] [LawfulFunctor n] {f : ∀ {α}, m α → n α} + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) : + IsFunctorHom m n f where + map_map := map_map + map_mapConst := map_mapConst_of_map_map f map_map + +variable (m) in +protected theorem id : IsFunctorHom m m id where + map_map _ _ := rfl + map_mapConst _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsFunctorHom n p f) (hg : IsFunctorHom m n g) : + IsFunctorHom m p (f ∘ g) where + map_map _ _ := by simp [hf.map_map, hg.map_map] + map_mapConst _ _ := by simp [hf.map_mapConst, hg.map_mapConst] + +end IsFunctorHom + + +/-! ### Applicative Homomorphisms -/ + +/-- +A function `f` is a morphism of applicatives if it preserves `pure`, `<$>`, `<*>`, `<*`, and `*>`. +-/ +structure IsApplicativeHom (m n) [Applicative m] [Applicative n] (f : ∀ {α}, m α → n α) : Prop + extends IsFunctorHom m n f where + map_pure {α} (a : α) : f (pure a) = pure a + map_seq {α β} (x : m (α → β)) (y : Unit → m α) : + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·) + map_seqLeft {α β} (x : m α) (y : Unit → m β) : + f (SeqLeft.seqLeft x y) = SeqLeft.seqLeft (f x) (f <| y ·) + map_seqRight {α β} (x : m α) (y : Unit → m β) : + f (SeqRight.seqRight x y) = SeqRight.seqRight (f x) (f <| y ·) + + +namespace IsApplicativeHom +variable {m n p : Type _ → Type _} [Applicative m] [Applicative n] [Applicative p] + +attribute [grind .] map_pure map_seq map_seqLeft map_seqRight +attribute [grind →] toIsFunctorHom + +private theorem map_map_of_map_pure_map_seq + [LawfulApplicative m] [LawfulApplicative n] (f : ∀ {α}, m α → n α) + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x := by + intros α β g x + rw [← pure_seq, ← pure_seq] + change f (Seq.seq (pure g) (fun _ => x)) = Seq.seq (pure g) (fun _ => f x) + rw [map_seq, map_pure] + +private theorem map_seqLeft_of_map_seq_map_map + [LawfulApplicative m] [LawfulApplicative n] (f : ∀ {α}, m α → n α) + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + ∀ {α β} (x : m α) (y : Unit → m β), + f (SeqLeft.seqLeft x y) = SeqLeft.seqLeft (f x) (f <| y ·) := by + intros α β x y + let y' := y (); have hy : y = fun _ => y' := rfl; clear_value y'; subst y + simp [seqLeft_eq, map_seq, map_map] + +private theorem map_seqRight_of_map_seq_map_map + [LawfulApplicative m] [LawfulApplicative n] (f : ∀ {α}, m α → n α) + (map_map : ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + ∀ {α β} (x : m α) (y : Unit → m β), + f (SeqRight.seqRight x y) = SeqRight.seqRight (f x) (f <| y ·) := by + intros α β x y + let y' := y (); have hy : y = fun _ => y' := rfl; clear_value y'; subst y + simp [seqRight_eq, map_seq, map_map] + +/-- Construct an `IsApplicativeHom` for lawful applicatives from `map_pure` and `map_seq`. -/ +theorem mk' [LawfulApplicative m] [LawfulApplicative n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) : + IsApplicativeHom m n f where + map_pure + toIsFunctorHom := .mk' (map_map_of_map_pure_map_seq f map_pure map_seq) + map_seq + map_seqLeft := map_seqLeft_of_map_seq_map_map f + (map_map_of_map_pure_map_seq f map_pure map_seq) map_seq + map_seqRight := map_seqRight_of_map_seq_map_map f + (map_map_of_map_pure_map_seq f map_pure map_seq) map_seq + +variable (m) in +protected theorem id : IsApplicativeHom m m id where + map_pure _ := rfl + toIsFunctorHom := IsFunctorHom.id m + map_seq _ _ := rfl + map_seqLeft _ _ := rfl + map_seqRight _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsApplicativeHom n p f) (hg : IsApplicativeHom m n g) : + IsApplicativeHom m p (f ∘ g) where + map_pure _ := by simp [hf.map_pure, hg.map_pure] + toIsFunctorHom := hf.toIsFunctorHom.comp hg.toIsFunctorHom + map_seq _ _ := by simp [hf.map_seq, hg.map_seq] + map_seqLeft _ _ := by simp [hf.map_seqLeft, hg.map_seqLeft] + map_seqRight _ _ := by simp [hf.map_seqRight, hg.map_seqRight] + +end IsApplicativeHom + + +/-! ### Monad Homomorphisms -/ + +/-- +A function `f` is a morphism of monads if it preserves `pure`, `>>=`, `<$>`, `<*>`, `<*`, and `*>`. +-/ +structure IsMonadHom (m n) [Monad m] [Monad n] (f : ∀ {α}, m α → n α) : Prop + extends IsApplicativeHom m n f where + map_bind {α β} (x : m α) (y : α → m β) : f (x >>= y) = f x >>= (f <| y ·) + +namespace IsMonadHom +variable {m n p : Type _ → Type _} [Monad m] [Monad n] [Monad p] + +attribute [grind .] map_bind +attribute [grind →] toIsApplicativeHom + +private theorem map_map_of_map_pure_map_bind + [LawfulMonad m] [LawfulMonad n] (f : ∀ {α}, m α → n α) + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) : + ∀ {α β} (g : α → β) (x : m α), f (g <$> x) = g <$> f x := by + intros α β g x + simp [← bind_pure_comp, map_bind, map_pure] + +private theorem map_seq_of_map_pure_map_bind + [LawfulMonad m] [LawfulMonad n] (f : ∀ {α}, m α → n α) + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) : + ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·) := by + intros α β x y + let y' := y (); have hy : y = fun _ => y' := rfl; clear_value y'; subst y + simp [seq_eq_bind_map, map_map_of_map_pure_map_bind f map_pure, map_bind] + +/-- Construct an `IsMonadHom` for lawful monads from `map_pure` and `map_bind`. -/ +theorem mk' [LawfulMonad m] [LawfulMonad n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) : + IsMonadHom m n f where + map_bind + toIsApplicativeHom := .mk' map_pure (map_seq_of_map_pure_map_bind f map_pure map_bind) + +variable (m) in +protected theorem id : IsMonadHom m m id where + toIsApplicativeHom := IsApplicativeHom.id m + map_bind _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsMonadHom n p f) (hg : IsMonadHom m n g) : + IsMonadHom m p (f ∘ g) where + toIsApplicativeHom := hf.toIsApplicativeHom.comp hg.toIsApplicativeHom + map_bind _ _ := by simp [hf.map_bind, hg.map_bind] + +protected theorem monadLift [LawfulMonad m] [LawfulMonad n] + [MonadLift m n] [LawfulMonadLift m n] : + IsMonadHom m n MonadLift.monadLift := + .mk' LawfulMonadLift.monadLift_pure LawfulMonadLift.monadLift_bind + +protected theorem monadLiftT [LawfulMonad m] [LawfulMonad n] + [MonadLiftT m n] [LawfulMonadLiftT m n] : + IsMonadHom m n monadLift := + .mk' LawfulMonadLiftT.monadLift_pure LawfulMonadLiftT.monadLift_bind + +end IsMonadHom + +/-! ### Alternative Homomorphisms -/ + +/-- +A function `f` is a morphism of alternatives if it preserves `pure`, `<$>`, `<*>`, `<*`, `*>`, +`failure`, and `orElse`. +-/ +structure IsAlternativeHom (m n) [Alternative m] [Alternative n] (f : ∀ {α}, m α → n α) : Prop + extends IsApplicativeHom m n f where + map_failure {α} : f (Alternative.failure : m α) = Alternative.failure + map_orElse {α} (x : m α) (y : Unit → m α) : + f (HOrElse.hOrElse x y) = HOrElse.hOrElse (f x) (f <| y ·) + +namespace IsAlternativeHom +variable {m n p : Type _ → Type _} [Alternative m] [Alternative n] [Alternative p] + +attribute [grind .] map_failure map_orElse +attribute [grind →] toIsApplicativeHom + +/-- Construct an `IsAlternativeHom` for lawful applicatives from `map_pure`, `map_seq`, +`map_failure`, and `map_orElse`. -/ +theorem mk' [LawfulApplicative m] [LawfulApplicative n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_seq : ∀ {α β} (x : m (α → β)) (y : Unit → m α), + f (Seq.seq x y) = Seq.seq (f x) (f <| y ·)) + (map_failure : ∀ {α}, f (Alternative.failure : m α) = Alternative.failure) + (map_orElse : ∀ {α} (x : m α) (y : Unit → m α), + f (HOrElse.hOrElse x y) = HOrElse.hOrElse (f x) (f <| y ·)) : + IsAlternativeHom m n f where + toIsApplicativeHom := .mk' map_pure map_seq + map_failure + map_orElse + +variable (m) in +protected theorem id : IsAlternativeHom m m id where + toIsApplicativeHom := IsApplicativeHom.id m + map_failure := rfl + map_orElse _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsAlternativeHom n p f) (hg : IsAlternativeHom m n g) : + IsAlternativeHom m p (f ∘ g) where + toIsApplicativeHom := hf.toIsApplicativeHom.comp hg.toIsApplicativeHom + map_failure := by simp [hf.map_failure, hg.map_failure] + map_orElse _ _ := by simp [hf.map_orElse, hg.map_orElse] + +end IsAlternativeHom + +/-! ### Alternative Monad Homomorphisms -/ + +/-- +A function `f` is a morphism of alternative monads if it preserves monadic and alternative +structure. +-/ +structure IsAlternativeMonadHom (m n) [AlternativeMonad m] [AlternativeMonad n] + (f : ∀ {α}, m α → n α) : Prop + extends IsMonadHom m n f, IsAlternativeHom m n f + +namespace IsAlternativeMonadHom +variable {m n p : Type _ → Type _} [AlternativeMonad m] [AlternativeMonad n] [AlternativeMonad p] + +attribute [grind →] toIsMonadHom toIsAlternativeHom + +/-- Construct an `IsAlternativeMonadHom` for lawful monads from `map_pure`, `map_bind`, +`map_failure`, and `map_orElse`. -/ +theorem mk' [LawfulMonad m] [LawfulMonad n] {f : ∀ {α}, m α → n α} + (map_pure : ∀ {α} (a : α), f (pure a) = pure a) + (map_bind : ∀ {α β} (x : m α) (y : α → m β), f (x >>= y) = f x >>= (f <| y ·)) + (map_failure : ∀ {α}, f (Alternative.failure : m α) = Alternative.failure) + (map_orElse : ∀ {α} (x : m α) (y : Unit → m α), + f (HOrElse.hOrElse x y) = HOrElse.hOrElse (f x) (f <| y ·)) : + IsAlternativeMonadHom m n f where + toIsMonadHom := .mk' map_pure map_bind + map_failure + map_orElse + +variable (m) in +protected theorem id : IsAlternativeMonadHom m m id where + toIsMonadHom := IsMonadHom.id m + map_failure := rfl + map_orElse _ _ := rfl + +protected theorem comp {f : ∀ {α}, n α → p α} {g : ∀ {α}, m α → n α} + (hf : IsAlternativeMonadHom n p f) (hg : IsAlternativeMonadHom m n g) : + IsAlternativeMonadHom m p (f ∘ g) where + toIsMonadHom := hf.toIsMonadHom.comp hg.toIsMonadHom + map_failure := by simp [hf.map_failure, hg.map_failure] + map_orElse _ _ := by simp [hf.map_orElse, hg.map_orElse] + +end IsAlternativeMonadHom + +open Std.Do WPMonad in +theorem IsMonadHom.wp [Monad m] [WPMonad m ps] : IsMonadHom m (PredTrans ps) WP.wp := + .mk' wp_pure wp_bind + +end Cslib diff --git a/Cslib/Foundations/Control/Monad/IsMonadHom/List.lean b/Cslib/Foundations/Control/Monad/IsMonadHom/List.lean new file mode 100644 index 0000000000..44e3cc6583 --- /dev/null +++ b/Cslib/Foundations/Control/Monad/IsMonadHom/List.lean @@ -0,0 +1,217 @@ +/- +Copyright (c) 2026 Eric Wieser. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Eric Wieser +-/ +module + +public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom +public import Mathlib.Data.List.Monad + +import all Init.Data.List.Control +import Mathlib.Data.List.Basic + +/-! +# List operations and monad morphisms + +This file proves that monadic operations on lists commute with monad homomorphisms +(and applicative homomorphisms), and that `List.reverse` is a monad homomorphism on `List`. +-/ + +public section + +namespace Cslib + +universe u um un v +variable {m : Type u → Type um} {n : Type u → Type un} + +/-! ### Preservation of list operations under applicative homomorphisms -/ + +namespace IsApplicativeHom +variable [Applicative m] [Applicative n] + +@[grind .] +theorem map_listMapA {F : ∀ {α}, m α → n α} (hf : IsApplicativeHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.mapA f) = l.mapA (F ∘ f) := by + induction l with grind [List.mapA] + +@[grind .] +theorem map_listForA {F : ∀ {α}, m α → n α} (hf : IsApplicativeHom m n F) + {α : Type v} (l : List α) (f : α → m PUnit) : + F (l.forA f) = l.forA (F ∘ f) := by + induction l with grind [List.forA] + +end IsApplicativeHom + +/-! ### Preservation of list operations under monad homomorphisms -/ + +namespace IsMonadHom +variable [Monad m] [Monad n] + +@[grind .] +theorem map_listMapM' + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.mapM' f) = l.mapM' (F ∘ f) := by + induction l with grind [List.mapM'] + +@[grind .] +theorem map_listMapMLoop + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) (acc : List β) : + F (List.mapM.loop f l acc) = List.mapM.loop (F ∘ f) l acc := by + induction l generalizing acc with + | nil => exact hf.map_pure _ + | cons a l ih => simp only [List.mapM.loop, hf.map_bind, ih, Function.comp_def] + +@[grind .] +theorem map_listMapM + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.mapM f) = l.mapM (F ∘ f) := by + grind [List.mapM] + +@[grind .] +theorem map_listForM {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} (l : List α) (f : α → m PUnit) : + F (l.forM f) = l.forM (F ∘ f) := by + induction l with grind [List.forM] + +@[grind .] +theorem map_listFoldlM {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {s : Type u} {α : Type v} (f : s → α → m s) (init : s) (l : List α) : + F (l.foldlM f init) = l.foldlM (fun s a => F (f s a)) init := by + induction l generalizing init with grind [List.foldlM] + +@[grind .] +theorem map_listFoldrM {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {s : Type u} {α : Type v} (f : α → s → m s) (init : s) (l : List α) : + F (l.foldrM f init) = l.foldrM (fun a s => F (f a s)) init := by + simp only [List.foldrM] + exact hf.map_listFoldlM (fun s a => f a s) init l.reverse + +@[grind .] +theorem map_listFindSomeM? + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} {β : Type u} (f : α → m (Option β)) (l : List α) : + F (l.findSomeM? f) = l.findSomeM? (F ∘ f) := by + induction l with grind + +@[grind .] +theorem map_listFindM? {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type} (p : α → m Bool) (l : List α) : + F (l.findM? p) = l.findM? (F ∘ p) := by + induction l with grind [List.findM?] + +@[grind .] +theorem map_listAnyM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} (p : α → m Bool) (l : List α) : + F (l.anyM p) = l.anyM (F ∘ p) := by + induction l with grind [List.anyM] + +@[grind .] +theorem map_listAllM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type v} (p : α → m Bool) (l : List α) : + F (l.allM p) = l.allM (F ∘ p) := by + induction l with grind [List.allM] + +@[grind .] +theorem map_listFilterAuxM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type} (p : α → m Bool) (l acc : List α) : + F (List.filterAuxM p l acc) = List.filterAuxM (F ∘ p) l acc := by + induction l generalizing acc with grind [List.filterAuxM] + +@[grind .] +theorem map_listFilterM {m n : Type → Type v} [Monad m] [Monad n] + {F : ∀ {α}, m α → n α} (hf : IsMonadHom m n F) + {α : Type} (p : α → m Bool) (l : List α) : + F (l.filterM p) = l.filterM (F ∘ p) := by + grind [List.filterM] + +end IsMonadHom + +/-! ### Preservation of list operations under alternative homomorphisms -/ + +namespace IsAlternativeHom +variable [Alternative m] [Alternative n] + +@[grind .] +theorem map_listFirstM {F : ∀ {α}, m α → n α} (hf : IsAlternativeHom m n F) + {α : Type v} {β : Type u} (f : α → m β) (l : List α) : + F (l.firstM f) = l.firstM (F ∘ f) := by + induction l with grind [List.firstM] + +end IsAlternativeHom + +/-! ### Monad homomorphisms on the `List` monad -/ + +@[grind .] +theorem IsApplicativeHom.map_listSingleton + {F : ∀ {α}, List α → List α} (hf : IsApplicativeHom List List F) {α} (a : α) : + F ([a] : List α) = [a] := hf.map_pure _ + +theorem IsMonadHom.map_listFlatMap + {F : ∀ {α}, List α → List α} (hf : IsMonadHom List List F) {α β} (l : List α) (g : α → List β) : + F (l.flatMap g) = (F l).flatMap (F <| g ·) := hf.map_bind _ _ + +@[grind .] +theorem IsFunctorHom.map_listNil {F : ∀ {α}, List α → List α} (hf : IsFunctorHom List List F) {α} : + F ([] : List α) = [] := by + simpa [Subsingleton.elim (F ([] : List PEmpty)) []] + using (hf.map_map PEmpty.elim []).symm + +protected theorem _root_.List.isMonadHom_reverse : IsMonadHom List List List.reverse := + .mk' (fun _ => rfl) (fun _ _ => List.reverse_flatMap) + +section uniqueness + +/-- A property holds on all lists if it holds on the nil list, the singleton list, +and concatenations thereof. -/ +private theorem List.nil_singleton_append_induction {α : Type*} {motive : List α → Prop} + (nil : motive []) (singleton : ∀ a, motive [a]) + (append : ∀ xs ys, motive xs → motive ys → motive (xs ++ ys)) : + ∀ l, motive l + | [] => nil + | x :: xs => append [x] xs (singleton x) (nil_singleton_append_induction nil singleton append xs) + +/-- Universe-generic type with two elements. This is used only internally in a proof, and keeps +things more concise than `ULift Bool`. -/ +private inductive Two : Type u | a | b + +private theorem eq_ab_or_ba : ∀ (l : List Two), + l.flatMap (fun | .a => [.a] | .b => []) = [Two.a] → + l.flatMap (fun | .a => [] | .b => [.b]) = [Two.b] → + l = [Two.a, Two.b] ∨ l = [Two.b, Two.a] + | [.a, .b], _, _ => .inl rfl + | [.b, .a], _, _ => .inr rfl + +/-- The only monad morphisms on lists are the identity and reversal. -/ +theorem isMonadHom_list_iff (f : ∀ {α : Type u}, List α → List α) : + IsMonadHom List List @f ↔ @f = (@id <| List ·) ∨ @f = @List.reverse := by + refine ⟨fun h => ?_, ?_⟩ + · have h_append {α} (xs ys : List α) : + f (xs ++ ys) = (f [Two.a, Two.b]).flatMap (fun | .a => f xs | .b => f ys) := by + have : xs ++ ys = [Two.a, Two.b].flatMap (fun | .a => xs | .b => ys) := by + simp + rw [this, h.map_listFlatMap] + congr 1; funext x; cases x <;> rfl + refine (eq_ab_or_ba (f [Two.a, Two.b]) ?_ ?_).imp (fun hL => ?_) (fun hL => ?_) + · simpa [h.map_listNil, h.map_listSingleton] using (h_append [Two.a] []).symm + · simpa [h.map_listNil, h.map_listSingleton] using (h_append [] [Two.b]).symm + · funext α l + induction l using List.nil_singleton_append_induction with grind + · funext α l + induction l using List.nil_singleton_append_induction with grind + · rintro (rfl | rfl) + · exact .id _ + · exact List.isMonadHom_reverse + +end uniqueness + +end Cslib diff --git a/Cslib/Foundations/Data/Nat/Asymptotics.lean b/Cslib/Foundations/Data/Nat/Asymptotics.lean new file mode 100644 index 0000000000..b852c7f38e --- /dev/null +++ b/Cslib/Foundations/Data/Nat/Asymptotics.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Init +public import Mathlib.Data.Nat.Log +public import Mathlib.Order.Filter.AtTopBot.Defs +import Mathlib.Analysis.SpecificLimits.Normed +import Mathlib.Tactic.Linarith + +/-! +# Asymptotic bounds on natural numbers + +For any natural base greater than one, exponentials eventually dominate fixed multiples of +powers, and fixed multiples of logarithms are eventually at most the input. The inequalities +are stated in `ℕ`; the polynomial bound specializes Mathlib's +`isLittleO_pow_const_const_pow_of_one_lt`. +-/ + +public section + +open Filter + +namespace Nat + +/-- Every fixed multiple of a power is eventually at most an exponential of base greater +than one. -/ +theorem eventually_mul_pow_le_pow (c k : ℕ) {b : ℕ} (hb : 1 < b) : + ∀ᶠ n : ℕ in atTop, c * n ^ k ≤ b ^ n := by + have hbR : (1 : ℝ) < b := by exact_mod_cast hb + have h := Asymptotics.isLittleO_iff_nat_mul_le.mp + (isLittleO_pow_const_const_pow_of_one_lt (R := ℝ) k hbR) c + filter_upwards [h] with n hn + exact_mod_cast (by simpa using hn : (c : ℝ) * n ^ k ≤ (b : ℝ) ^ n) + +/-- The quotient of an exponential of base greater than one by the input is eventually +at least the input plus one. -/ +theorem eventually_add_one_le_pow_div {b : ℕ} (hb : 1 < b) : + ∀ᶠ n : ℕ in atTop, n + 1 ≤ b ^ n / n := by + filter_upwards [eventually_mul_pow_le_pow 2 2 hb, eventually_ge_atTop 1] with n hn hn0 + apply (Nat.le_div_iff_mul_le (by omega)).mpr + nlinarith + +/-- Every fixed multiple of the logarithm in a base greater than one is eventually at most +the input. -/ +theorem eventually_mul_log_le (c : ℕ) {b : ℕ} (hb : 1 < b) : + ∀ᶠ n : ℕ in atTop, c * log b n ≤ n := by + obtain ⟨N, hN⟩ := eventually_atTop.mp (eventually_mul_pow_le_pow c 1 hb) + filter_upwards [eventually_ge_atTop (b ^ N)] with n hn + have hn0 : n ≠ 0 := ne_of_gt ((pow_pos (by omega) N).trans_le hn) + have hh : c * log b n ≤ b ^ log b n := by + simpa using hN (log b n) (le_log_of_pow_le hb hn) + exact hh.trans (pow_log_le_self b hn0) + +/-- Every fixed multiple of the binary logarithm is eventually at most the input. -/ +theorem eventually_mul_log2_le (c : ℕ) : + ∀ᶠ n : ℕ in atTop, c * log2 n ≤ n := by + simpa only [log2_eq_log_two] using eventually_mul_log_le c one_lt_two + +end Nat diff --git a/Cslib/Foundations/Data/Nat/Factorial.lean b/Cslib/Foundations/Data/Nat/Factorial.lean new file mode 100644 index 0000000000..bc72f11578 --- /dev/null +++ b/Cslib/Foundations/Data/Nat/Factorial.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ +module + +public import Cslib.Init +public import Mathlib.Analysis.SpecialFunctions.Log.Basic + +/-! +# A logarithmic lower bound for the factorial + +Bounding one term of the exponential series gives `n log n - n ≤ log (n!)`, including at zero. +-/ + +public section + +namespace Nat + +/-- The logarithm of the factorial is at least `n log n - n`. -/ +theorem mul_log_sub_le_log_factorial (n : ℕ) : + (n : ℝ) * Real.log n - n ≤ Real.log n.factorial := by + obtain rfl | hn := n.eq_zero_or_pos + · simp + have h := Real.log_le_log (by positivity : 0 < (n : ℝ) ^ n / n.factorial) + (Real.pow_div_factorial_le_exp (n : ℝ) (by positivity) n) + rw [Real.log_div (by positivity) (by positivity), Real.log_pow, Real.log_exp] at h + linarith + +end Nat diff --git a/Cslib/Foundations/Data/PFunctor/Free.lean b/Cslib/Foundations/Data/PFunctor/Free.lean index a29e974704..05cb6535d0 100644 --- a/Cslib/Foundations/Data/PFunctor/Free.lean +++ b/Cslib/Foundations/Data/PFunctor/Free.lean @@ -7,6 +7,7 @@ Authors: Quang Dao module public import Cslib.Init +public import Cslib.Foundations.Control.Monad.IsMonadHom public import Mathlib.Data.PFunctor.Univariate.Basic /-! @@ -321,6 +322,16 @@ theorem Interprets.iff (handler : (a : P.A) → m (P.B a)) (eval : P.FreeM α Interprets handler eval ↔ eval = (·.liftM handler) := ⟨(·.eq), fun h => h ▸ Interprets.liftM _⟩ +/-- A morphism of monads moves inside `FreeM.liftM`. -/ +theorem _root_.Cslib.IsMonadHom.map_pfunctorFreeMLiftM [Monad n] + {f : ∀ {α}, m α → n α} (hf : Cslib.IsMonadHom m n f) (interp : (a : P.A) → m (P.B a)) + (x : P.FreeM α) : + f (x.liftM interp) = x.liftM (fun op => f (interp op)) := by + induction x with + | pure a => exact hf.map_pure a + | lift_bind op cont ih => + simp only [bind_eq_bind, liftM_lift_bind, hf.map_bind, ih] + variable [LawfulMonad m] @[simp] @@ -336,28 +347,32 @@ lemma liftM_bind {α β : Type uB} (x : P.FreeM α) (f : α → P.FreeM β) : funext u exact h u +/-- `FreeM.liftM interp` is a morphism of monads. -/ +theorem isMonadHom_liftM : Cslib.IsMonadHom P.FreeM m (FreeM.liftM interp) := + .mk' (liftM_pure interp) (liftM_bind interp) + @[simp] -lemma liftM_map {α β : Type uB} (f : α → β) (x : P.FreeM α) : - (f <$> x).liftM interp = f <$> x.liftM interp := by - simp_rw [← LawfulMonad.bind_pure_comp, liftM_bind, liftM_pure] +lemma liftM_map {α β : Type uB} (f : α → β) (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) : + (f <$> x).liftM interp = f <$> x.liftM interp := + isMonadHom_liftM interp |>.map_map _ _ @[simp] lemma liftM_seq {α β : Type uB} (interp : (a : P.A) → m (P.B a)) (x : P.FreeM (α → β)) (y : P.FreeM α) : - (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := by - simp [seq_eq_bind_map] + (x <*> y).liftM interp = x.liftM interp <*> y.liftM interp := + isMonadHom_liftM interp |>.map_seq _ _ @[simp] lemma liftM_seqLeft {α β : Type uB} (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) (y : P.FreeM β) : - (x <* y).liftM interp = x.liftM interp <* y.liftM interp := by - simp [seqLeft_eq_bind] + (x <* y).liftM interp = x.liftM interp <* y.liftM interp := + isMonadHom_liftM interp |>.map_seqLeft _ _ @[simp] lemma liftM_seqRight {α β : Type uB} (interp : (a : P.A) → m (P.B a)) (x : P.FreeM α) (y : P.FreeM β) : - (x *> y).liftM interp = x.liftM interp *> y.liftM interp := by - simp [seqRight_eq_bind] + (x *> y).liftM interp = x.liftM interp *> y.liftM interp := + isMonadHom_liftM interp |>.map_seqRight _ _ @[simp] lemma liftM_lift (interp : (a : P.A) → m (P.B a)) (a : P.A) : diff --git a/Cslib/Foundations/Relation/Basic.lean b/Cslib/Foundations/Relation/Basic.lean index aafcddac21..9369e346cf 100644 --- a/Cslib/Foundations/Relation/Basic.lean +++ b/Cslib/Foundations/Relation/Basic.lean @@ -9,7 +9,13 @@ module public import Cslib.Foundations.Relation.Defs public import Mathlib.Order.WellFounded -/-! # Basic properties of relations -/ +/-! # Basic properties of relations + +## TODO: +Many of the results here could be upstreamed to Mathlib. In particular: +- `ReflGen.le_reflGen` and relatives, +- `ReflGen.to_eqvGen` and relatives. +-/ @[expose] public section @@ -24,6 +30,8 @@ theorem WellFounded.iff_transGen : WellFounded (Relation.TransGen r) ↔ WellFou namespace Relation +open Function + /-- A pair of subrelations lifts to transitivity on the relation. -/ @[implicit_reducible] def transLeftRight (s s' r : α → α → Prop) [IsTrans α r] (h : s ≤ r) (h' : s' ≤ r) : @@ -40,28 +48,105 @@ def transLeft (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans s def transRight (s r : α → α → Prop) [IsTrans α r] (h : s ≤ r) : Trans r s r where trans hab hbc := _root_.trans hab (h _ _ hbc) +@[scoped grind .] +theorem comp_le_comp {s s' r r' : α → α → Prop} (hs : s ≤ s') (hr : r ≤ r') : + Comp s r ≤ Comp s' r' := fun a c ⟨b, hab, hbc⟩ ↦ ⟨b, hs a b hab, hr b c hbc⟩ + +theorem comp_self_le (r : α → α → Prop) [IsTrans α r] : Comp r r ≤ r := + fun _ _ ⟨_, hab, hbc⟩ ↦ _root_.trans hab hbc + +theorem swap_le_iff_le_swap {r₁ r₂ : α → α → Prop} : swap r₁ ≤ r₂ ↔ r₁ ≤ swap r₂ := by + constructor <;> intro h a b hab <;> exact h b a hab + attribute [scoped grind] ReflGen TransGen ReflTransGen EqvGen +@[scoped grind .] +theorem ReflGen.le_reflGen : r ≤ ReflGen r := fun _ _ => ReflGen.single + theorem ReflGen.to_eqvGen (h : ReflGen r a b) : EqvGen r a b := EqvGen.reflGen_le_eqvGen r _ _ h +@[scoped grind .] +theorem TransGen.le_transGen : r ≤ TransGen r := fun _ _ => TransGen.single + theorem TransGen.to_eqvGen (h : TransGen r a b) : EqvGen r a b := EqvGen.transGen_le_eqvGen r _ _ h theorem ReflTransGen.to_eqvGen (h : ReflTransGen r a b) : EqvGen r a b := EqvGen.reflTransGen_le_eqvGen r _ _ h +@[scoped grind .] +theorem SymmGen.le_symmGen : r ≤ SymmGen r := fun _ _ => Or.inl + theorem SymmGen.to_eqvGen (h : SymmGen r a b) : EqvGen r a b := EqvGen.symmGen_le_eqvGen r _ _ h +@[simp, scoped grind =] theorem sup_swap_eq_symmGen : r ⊔ Function.swap r = SymmGen r := rfl + +@[scoped grind .] +theorem EqvGen.le_eqvGen : r ≤ EqvGen r := EqvGen.rel + +theorem _root_.Equivalence.eqvGen_le (h : Equivalence r₂) (hle : r₁ ≤ r₂) : EqvGen r₁ ≤ r₂ := + have := h.isEquiv + EqvGen.eqvGen_le hle + attribute [scoped grind →] ReflGen.to_eqvGen TransGen.to_eqvGen ReflTransGen.to_eqvGen SymmGen.to_eqvGen -@[deprecated _root_.refl (since := "2026-09-07")] +theorem Join.single [Std.Refl r] (h : r a b) : Join r a b := ⟨b, h, refl b⟩ + +@[simp, scoped grind =] theorem join₂_eq_join : Join₂ r r = Join r := rfl + +theorem join₂_eq_comp_swap : Join₂ r₁ r₂ = Comp r₁ (swap r₂) := rfl + +instance [Std.Refl r₁] [Std.Refl r₂] : Std.Refl (Join₂ r₁ r₂) where + refl a := ⟨a, refl a, refl a⟩ + +theorem Join₂.single_left [Std.Refl r₂] (h : r₁ a b) : Join₂ r₁ r₂ a b := ⟨b, h, refl b⟩ + +theorem Join₂.single_right [Std.Refl r₁] (h : r₂ a b) : Join₂ r₁ r₂ b a := ⟨b, refl b, h⟩ + +theorem Join₂.join₂_le [IsTrans α r] (h₁ : r₁ ≤ r) (h₂ : swap r₂ ≤ r) : Join₂ r₁ r₂ ≤ r := + (comp_le_comp h₁ h₂).trans (comp_self_le r) + +theorem Join₂.swap_iff {a b : α} : Join₂ r₁ r₂ b a ↔ Join₂ r₂ r₁ a b := by grind [Join₂] + +protected theorem Join₂.mono (h₁ : r₁ ≤ r₁') (h₂ : r₂ ≤ r₂') : Join₂ r₁ r₂ ≤ Join₂ r₁' r₂' := + fun x y ⟨z, hxz, hyz⟩ => ⟨z, h₁ x z hxz, h₂ y z hyz⟩ + +@[deprecated _root_.refl +typeChanged (since := "2026-09-07")] theorem MJoin.refl (a : α) : MJoin r a a := _root_.refl a -theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := by - use b +@[deprecated Join.single +typeChanged (since := "2026-09-07")] +theorem MJoin.single (h : ReflTransGen r a b) : MJoin r a b := Join.single h + +theorem _root_.Equivalence.join_reflTransGen_le (h : Equivalence r₂) (hle : r₁ ≤ r₂) : + Join (ReflTransGen r₁) ≤ r₂ := + have := h.isEquiv + join_le_of_equivalence_of_le h <| reflTransGen_le_of_le hle + +theorem join_reflTransGen_le_eqvGen : Join (ReflTransGen r) ≤ EqvGen r := + (EqvGen.is_equivalence r).join_reflTransGen_le EqvGen.le_eqvGen + +theorem join₂_reflTransGen_le [Std.Refl r] [IsTrans α r] (h₁ : r₁ ≤ r) (h₂ : swap r₂ ≤ r) : + Join₂ (ReflTransGen r₁) (ReflTransGen r₂) ≤ r := by + refine Join₂.join₂_le ?_ (ReflTransGen.swap.trans ?_) + <;> apply reflTransGen_le_of_le <;> assumption + +theorem join₂_reflTransGen_le_of_isEquiv [IsEquiv α r] (h₁ : r₁ ≤ r) (h₂ : r₂ ≤ r) : + Join₂ (ReflTransGen r₁) (ReflTransGen r₂) ≤ r := + join₂_reflTransGen_le h₁ (by rwa [swap_le_iff_le_swap, Std.Symm.swap_eq]) + +theorem _root_.Equivalence.join₂_reflTransGen_le (h : Equivalence r) (h₁ : r₁ ≤ r) (h₂ : r₂ ≤ r) : + Join₂ (ReflTransGen r₁) (ReflTransGen r₂) ≤ r := + have := h.isEquiv + join₂_reflTransGen_le_of_isEquiv h₁ h₂ + +theorem left_le_join₂_reflTransGen : r₁ ≤ Join₂ (ReflTransGen r₁) (ReflTransGen r₂) := + fun _ _ h => Join₂.single_left (.single h) + +theorem swap_right_le_join₂_reflTransGen : swap r₂ ≤ Join₂ (ReflTransGen r₁) (ReflTransGen r₂) := + fun _ _ h => Join₂.single_right (.single h) /-- If a relation is squeezed by a relation and its multi-step closure, they are multi-step equal -/ theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTransGen r₁) : @@ -69,11 +154,27 @@ theorem reflTransGen_mono_closed (h₁ : r₁ ≤ r₂) (h₂ : r₂ ≤ ReflTra ext a b exact ⟨ReflTransGen.mono h₁ a b, reflTransGen_closed h₂ a b⟩ -@[deprecated Relation.ReflGen.stdSymm (since := "2026-09-03")] +@[deprecated Relation.ReflGen.stdSymm +typeChanged (since := "2026-09-03")] lemma ReflGen.symmGen_symm : ReflGen (SymmGen r) a b → ReflGen (SymmGen r) b a := Std.Symm.symm a b -@[simp, grind =] +@[simp, scoped grind =] theorem reflTransGen_symmGen : ReflTransGen (SymmGen r) = EqvGen r := EqvGen.reflTransGen_symmGen r +@[scoped grind <=] +theorem join_inl (r₁_ab : r₁ a b) : (r₁ ⊔ r₂) a b := + Or.inl r₁_ab + +@[scoped grind <=] +theorem join_inr (r₂_ab : r₂ a b) : (r₁ ⊔ r₂) a b := + Or.inr r₂_ab + +@[scoped grind <=] +theorem join_inl_reflTransGen (r₁_ab : ReflTransGen r₁ a b) : ReflTransGen (r₁ ⊔ r₂) a b := + ReflTransGen.mono le_sup_left _ _ r₁_ab + +@[scoped grind <=] +theorem join_inr_reflTransGen (r₂_ab : ReflTransGen r₂ a b) : ReflTransGen (r₁ ⊔ r₂) a b := + ReflTransGen.mono le_sup_right _ _ r₂_ab + end Relation diff --git a/Cslib/Foundations/Relation/Confluence.lean b/Cslib/Foundations/Relation/Confluence.lean index bdfb8b8576..02798537e8 100644 --- a/Cslib/Foundations/Relation/Confluence.lean +++ b/Cslib/Foundations/Relation/Confluence.lean @@ -7,9 +7,9 @@ Authors: Fabrizio Montesi, Thomas Waring, Chris Henson module public import Cslib.Foundations.Relation.Termination -public import Mathlib.Data.List.Pairwise +public import Mathlib.Tactic.TFAE -/-! # Relations: Confluence and Termination +/-! # Relations: Confluence This module proves some properties regarding confluence that are used for both lambda calculi and combinatory logic. Some notable theorems: @@ -17,6 +17,9 @@ combinatory logic. Some notable theorems: * `Diamond.to_confluent`: the diamond property implies confluence * `LocallyConfluent.terminating_toConfluent`: Newman's lemma +We prove most results first for two relations, where `Confluent r` becomes `Commute r₁ r₂`, then +specialize to the classical case where `r₁ = r₂`. + ## References * [*Term Rewriting and All That*][Baader1998] @@ -29,60 +32,115 @@ variable {α : Type*} {r r₁ r₂ : α → α → Prop} namespace Relation +open Function ReflTransGen + +theorem Commute.to_confluent : Commute r r = Confluent r := rfl + +@[deprecated (since := "2026-09-03")] alias Commute.toConfluent := Commute.to_confluent + +@[simp] theorem StronglyCommute.to_stronglyConfluent : + StronglyCommute r r = StronglyConfluent r := rfl + +@[deprecated (since := "2026-09-03")] alias StronglyCommute.toStronglyConfluent := + StronglyCommute.to_stronglyConfluent + +@[simp] theorem DiamondCommute.to_diamond : DiamondCommute r r = Diamond r := rfl + +@[deprecated (since := "2026-09-03")] alias DiamondCommute.toDiamond := DiamondCommute.to_diamond + +@[simp] theorem SemiCommute.to_semiConfluent : SemiCommute r r = SemiConfluent r := rfl + +@[simp] theorem LocallyCommute.to_locallyConfluent : LocallyCommute r r = LocallyConfluent r := rfl + +instance : Std.Symm (@DiamondCommute α) where + symm _ _ h _ _ _ h₁ h₂ := Join₂.swap_iff.mp <| h h₂ h₁ + +instance : Std.Symm (@LocallyCommute α) where + symm _ _ h _ _ _ h₁ h₂ := Join₂.swap_iff.mp <| h h₂ h₁ + +lemma DiamondCommute.diamond_commute_reflTransGen_right (h : DiamondCommute r₁ r₂) : + DiamondCommute r₁ (ReflTransGen r₂) := by + intro a b c h₁ h₂ + induction h₂ using ReflTransGen.head_induction_on generalizing b with + | refl => exact Join₂.single_right h₁ + | head ha _ ih => + obtain ⟨d, hbd, hcd⟩ := h h₁ ha + obtain ⟨d', hdd', hcd'⟩ := ih hcd + exact ⟨d', hdd'.head hbd, hcd'⟩ + +lemma DiamondCommute.diamond_commute_reflTransGen_left (h : DiamondCommute r₁ r₂) : + DiamondCommute (ReflTransGen r₁) r₂ := by + rw [comm (r := DiamondCommute)] at h ⊢ + exact h.diamond_commute_reflTransGen_right + +lemma DiamondCommute.to_semiCommute (h : DiamondCommute r₁ r₂) : SemiCommute r₁ r₂ := + fun h₁ h₂ => Join₂.mono le_rfl ReflTransGen.le_reflTransGen _ _ <| + h.diamond_commute_reflTransGen_right h₁ h₂ + /-- Extending a multistep reduction by a single step preserves multi-joinability. -/ -lemma Diamond.extend (h : Diamond r) : - ReflTransGen r a b → r a c → Join (ReflTransGen r) b c := by - intros ab ac - induction ab using ReflTransGen.head_induction_on generalizing c - case refl => exists c, .single ac - case head a'_c' _ ih => - obtain ⟨d, cd, c'_d⟩ := h ac a'_c' - obtain ⟨d', b_d', d_d'⟩ := ih c'_d - exact ⟨d', b_d', .head cd d_d'⟩ - -/-- The diamond property implies confluence. -/ -theorem Diamond.to_confluent (h : Diamond r) : Confluent r := by - intros a b c ab bc - induction ab using ReflTransGen.head_induction_on generalizing c - case refl => exists c - case head _ _ a'_c' _ ih => - obtain ⟨d, cd, c'_d⟩ := h.extend bc a'_c' - obtain ⟨d', b_d', d_d'⟩ := ih c'_d - exact ⟨d', b_d', .trans cd d_d'⟩ +lemma Diamond.to_semiConfluent (h : Diamond r) : SemiConfluent r := DiamondCommute.to_semiCommute h -@[deprecated (since := "2026-09-03")] alias Diamond.toConfluent := Diamond.to_confluent +@[deprecated (since := "2026-09-12")] alias Diamond.extend := Diamond.to_semiConfluent -theorem Confluent.to_churchRosser (h : Confluent r) : ChurchRosser r := by - intro x y h_eqv - induction h_eqv with - | rel _ b => exists b; grind [ReflTransGen.single] - | refl a => exists a - | symm a b _ ih => exact symm ih - | trans _ _ _ _ _ ih1 ih2 => - obtain ⟨u, _, hbu⟩ := ih1 - obtain ⟨v, hbv, _⟩ := ih2 - obtain ⟨w, _, _⟩ := h hbu hbv - exists w - grind [ReflTransGen.trans] - -@[deprecated (since := "2026-09-03")] alias Confluent.toChurchRosser := Confluent.to_churchRosser - -theorem SemiConfluent.to_confluent (h : SemiConfluent r) : Confluent r := by - intro x y1 y2 h_xy1 h_xy2 - induction h_xy1 with - | refl => use y2 - | tail h_xz h_zy1 ih => - obtain ⟨u, h_zu, _⟩ := ih - obtain ⟨v, _, _⟩ := h h_zu h_zy1 - exists v - grind [ReflTransGen.trans] +theorem Commute.isTrans_join₂_reflTransGen (h : Commute r₁ r₂) : + IsTrans α (Join₂ (ReflTransGen r₁) (ReflTransGen r₂)) where + trans a b c := by + intro ⟨d, had, hbd⟩ ⟨d', hbd', hcd'⟩ + obtain ⟨e, he, he'⟩ := h hbd' hbd + exact ⟨e, had.trans he', hcd'.trans he⟩ -@[deprecated (since := "2026-09-03")] alias SemiConfluent.toConfluent := SemiConfluent.to_confluent +theorem Confluent.isTrans_join_reflTransGen (h : Confluent r) : IsTrans α (Join (ReflTransGen r)) := + Commute.isTrans_join₂_reflTransGen h -attribute [scoped grind →] Confluent.to_churchRosser SemiConfluent.to_confluent +theorem SemiCommute.to_commute (h : SemiCommute r₁ r₂) : Commute r₁ r₂ := by + intro a b₁ b₂ hab₁ hab₂ + induction hab₁ with + | refl => use b₂ + | tail hab hbb' ih => + obtain ⟨d, hd, hd'⟩ := ih + obtain ⟨e, he, he'⟩ := h hbb' hd + use e, he, hd'.trans he' -private theorem confluent_equivalents : [ChurchRosser r, SemiConfluent r, Confluent r].TFAE := by - grind [List.tfae_cons_cons, List.tfae_singleton] +theorem SemiConfluent.to_confluent (h : SemiConfluent r) : Confluent r := SemiCommute.to_commute h + +@[deprecated (since := "2026-09-03")] alias SemiConfluent.toConfluent := SemiConfluent.to_confluent + +theorem commute_equivalents : + [SemiCommute r₁ r₂, Commute r₁ r₂, IsTrans α (Join₂ (ReflTransGen r₁) (ReflTransGen r₂)), + ReflTransGen (r₁ ⊔ swap r₂) ≤ Join₂ (ReflTransGen r₁) (ReflTransGen r₂), + ReflTransGen (r₁ ⊔ swap r₂) = Join₂ (ReflTransGen r₁) (ReflTransGen r₂)].TFAE := by + tfae_have 1 → 2 := SemiCommute.to_commute + tfae_have 2 → 3 := Commute.isTrans_join₂_reflTransGen + tfae_have 3 → 4 := fun h => reflTransGen_le_of_le <| + sup_le left_le_join₂_reflTransGen swap_right_le_join₂_reflTransGen + tfae_have 4 → 5 := fun h => h.antisymm <| + join₂_reflTransGen_le (le_sup_left.trans le_reflTransGen) (le_sup_right.trans le_reflTransGen) + tfae_have 5 → 1 := by + intro h a b₁ b₂ h₁ h₂ + rw [Join₂.swap_iff, ← h] + exact (ReflTransGen.mono le_sup_right _ _ <| reflTransGen_swap.mpr h₂).tail (Or.inl h₁) + tfae_finish + +theorem semiCommute_iff_commute : SemiCommute r₁ r₂ ↔ Commute r₁ r₂ := commute_equivalents.out 1 2 + +theorem DiamondCommute.to_commute (h : DiamondCommute r₁ r₂) : Commute r₁ r₂ := + semiCommute_iff_commute.mp h.to_semiCommute + +instance : Std.Symm (@SemiCommute α) where + symm r₁ r₂ h := by + rw [semiCommute_iff_commute] at h ⊢ + exact symm (r := Commute) h + +theorem churchRosser_iff_eqvGen_le_join_reflTransGen : + ChurchRosser r ↔ EqvGen r ≤ Join (ReflTransGen r) := + Iff.rfl + +theorem confluent_equivalents : + [ChurchRosser r, SemiConfluent r, Confluent r, IsTrans α (Join (ReflTransGen r)), + EqvGen r ≤ Join (ReflTransGen r), EqvGen r = Join (ReflTransGen r)].TFAE := by + refine (List.tfae_cons ?_).mpr ⟨churchRosser_iff_eqvGen_le_join_reflTransGen, ?_⟩ + · grind + · simpa [reflTransGen_symmGen] using commute_equivalents (r₁ := r) (r₂ := r) theorem semiConfluent_iff_churchRosser : SemiConfluent r ↔ ChurchRosser r := List.TFAE.out confluent_equivalents 2 1 @@ -93,14 +151,22 @@ theorem semiConfluent_iff_churchRosser : SemiConfluent r ↔ ChurchRosser r := theorem confluent_iff_churchRosser : Confluent r ↔ ChurchRosser r := List.TFAE.out confluent_equivalents 3 1 +alias ⟨Confluent.to_churchRosser, _⟩ := confluent_iff_churchRosser + @[deprecated (since := "2026-09-03")] alias Confluent_iff_ChurchRosser := confluent_iff_churchRosser +attribute [scoped grind →] Confluent.to_churchRosser SemiConfluent.to_confluent + theorem confluent_iff_semiConfluent : Confluent r ↔ SemiConfluent r := List.TFAE.out confluent_equivalents 3 2 @[deprecated (since := "2026-09-03")] alias Confluent_iff_SemiConfluent := confluent_iff_semiConfluent +theorem Diamond.to_confluent (h : Diamond r) : Confluent r := DiamondCommute.to_commute h + +@[deprecated (since := "2026-09-03")] alias Diamond.toConfluent := Diamond.to_confluent + theorem confluent_of_unique_end {x : α} (h : ∀ y : α, ReflTransGen r y x) : Confluent r := by intro a b c hab hac exact ⟨x, h b, h c⟩ @@ -125,9 +191,8 @@ theorem Confluent.equivalence_join_reflTransGen (h : Confluent r) : apply equivalence_join grind -theorem Terminating.confluent_iff_forall_unique_normal (ht : Terminating r) : +theorem Normalizing.confluent_iff_forall_unique_normal (hn : Normalizing r) : Confluent r ↔ ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := by - have hn : Normalizing r := ht.to_normalizing constructor · intro hc a apply existsUnique_of_exists_of_unique (hn a) @@ -142,11 +207,11 @@ theorem Terminating.confluent_iff_forall_unique_normal (ht : Terminating r) : obtain ⟨nc, hcnc, hnc⟩ := hn c have hanb : (ReflTransGen r) a nb := ReflTransGen.trans hab hbnb have hanc : (ReflTransGen r) a nc := ReflTransGen.trans hac hcnc - have hnanb : nb = na := H nb ⟨hanb, hnb⟩ - have hnanc : nc = na := H nc ⟨hanc, hnc⟩ - rw [hnanb] at hbnb - rw [hnanc] at hcnc - exact ⟨hbnb, hcnc⟩ + grind + +theorem Terminating.confluent_iff_forall_unique_normal (ht : Terminating r) : + Confluent r ↔ ∀ a : α, ∃! n : α, ReflTransGen r a n ∧ Normal r n := + ht.to_normalizing.confluent_iff_forall_unique_normal @[deprecated (since := "2026-09-03")] alias Terminating.isConfluent_iff_all_unique_Normal := Terminating.confluent_iff_forall_unique_normal @@ -177,45 +242,28 @@ theorem Confluent.to_locallyConfluent (h : Confluent r) : LocallyConfluent r := @[deprecated (since := "2026-09-03")] alias Confluent.toLocallyConfluent := Confluent.to_locallyConfluent -/-- Newman's lemma: a terminating, locally confluent relation is confluent. -/ -theorem LocallyConfluent.terminating_toConfluent (hlc : LocallyConfluent r) (ht : Terminating r) : - Confluent r := by +theorem LocallyCommute.commute_of_terminating_sup (hlc : LocallyCommute r₁ r₂) + (ht : Terminating (r₁ ⊔ r₂)) : Commute r₁ r₂ := by intro x induction x using ht.induction with | h x ih => - intro y z xy xz - cases xy.cases_head with - | inl => exists z; grind - | inr h => - obtain ⟨y₁, x_y₁, y₁_y⟩ := h - cases xz.cases_head with - | inl => exists y; grind - | inr h => - obtain ⟨z₁, x_z₁, z₁_z⟩ := h - have ⟨u, z₁_u, y₁_u⟩ := hlc x_z₁ x_y₁ - have ⟨v, uv, yv⟩ : Join (ReflTransGen r) u y := by grind - have ⟨w, vw, zw⟩ : Join (ReflTransGen r) v z := by grind [ReflTransGen.trans] - exact ⟨w, .trans yv vw, zw⟩ + intro y z hy hz + rcases hy.cases_head with (rfl | ⟨y', hy, hy'⟩) + · use z + · rcases hz.cases_head with (rfl | ⟨z', hz, hz'⟩) + · use y + · obtain ⟨u, hyu, hzu⟩ := hlc hy hz + obtain ⟨v, hyv, huv⟩ := ih y' (join_inl hy) hy' hyu + obtain ⟨w, hvw, hzw⟩ := ih z' (join_inr hz) (hzu.trans huv) hz' + exact ⟨w, hyv.trans hvw, hzw⟩ + +/-- Newman's lemma: a terminating, locally confluent relation is confluent. -/ +theorem LocallyConfluent.terminating_toConfluent (hlc : LocallyConfluent r) (ht : Terminating r) : + Confluent r := LocallyCommute.commute_of_terminating_sup hlc ((sup_idem r).symm ▸ ht) @[deprecated (since := "2026-09-03")] alias LocallyConfluent.Terminating_toConfluent := LocallyConfluent.terminating_toConfluent -instance : Std.Symm (@Commute α) where - symm r₁ r₂ h x y₁ y₂ x_y₁ x_y₂ := by grind [h x_y₂ x_y₁] - -theorem Commute.to_confluent : Commute r r = Confluent r := rfl - -@[deprecated (since := "2026-09-03")] alias Commute.toConfluent := Commute.to_confluent - -theorem StronglyCommute.to_stronglyConfluent : StronglyCommute r r = StronglyConfluent r := rfl - -@[deprecated (since := "2026-09-03")] alias StronglyCommute.toStronglyConfluent := - StronglyCommute.to_stronglyConfluent - -theorem DiamondCommute.to_diamond : DiamondCommute r r = Diamond r := by rfl - -@[deprecated (since := "2026-09-03")] alias DiamondCommute.toDiamond := DiamondCommute.to_diamond - theorem StronglyCommute.extend (h : StronglyCommute r₁ r₂) (xy : ReflTransGen r₁ x y) (xz : r₂ x z) : ∃ w, ReflGen r₂ y w ∧ ReflTransGen r₁ z w := by induction xy with @@ -243,37 +291,19 @@ theorem StronglyConfluent.to_confluent (h : StronglyConfluent r) : Confluent r : @[deprecated (since := "2026-09-03")] alias StronglyConfluent.toConfluent := StronglyConfluent.to_confluent -variable {r₁ r₂ : α → α → Prop} - -@[scoped grind <=] -theorem join_inl (r₁_ab : r₁ a b) : (r₁ ⊔ r₂) a b := - Or.inl r₁_ab - -@[scoped grind <=] -theorem join_inr (r₂_ab : r₂ a b) : (r₁ ⊔ r₂) a b := - Or.inr r₂_ab - -@[scoped grind <=] -theorem join_inl_reflTransGen (r₁_ab : ReflTransGen r₁ a b) : ReflTransGen (r₁ ⊔ r₂) a b := - ReflTransGen.mono le_sup_left _ _ r₁_ab - -@[scoped grind <=] -theorem join_inr_reflTransGen (r₂_ab : ReflTransGen r₂ a b) : ReflTransGen (r₁ ⊔ r₂) a b := - ReflTransGen.mono le_sup_right _ _ r₂_ab - lemma Commute.join_left (c₁ : Commute r₁ r₃) (c₂ : Commute r₂ r₃) : Commute (r₁ ⊔ r₂) r₃ := by intro x y z xy xz induction xy with - | refl => grind + | refl => grind [Join₂] | @tail b c _ bc ih => have ⟨w, bw, _⟩ := ih cases bc with | inl bc => obtain ⟨_, _, _⟩ := c₁ (.single bc) bw - grind [ReflTransGen.trans] + grind [Join₂, ReflTransGen.trans] | inr bc => obtain ⟨_, _, _⟩ := c₂ (.single bc) bw - grind [ReflTransGen.trans] + grind [Join₂, ReflTransGen.trans] theorem Commute.join_confluent (c₁ : Confluent r₁) (c₂ : Confluent r₂) (comm : Commute r₁ r₂) : Confluent (r₁ ⊔ r₂) := by @@ -291,4 +321,10 @@ theorem RightUnique.to_confluent (hr : Relator.RightUnique r) : Confluent r := b @[deprecated (since := "2026-09-03")] alias RightUnique.toConfluent := RightUnique.to_confluent +theorem Reducible.sup_iff (x : α) : Reducible (r₁ ⊔ r₂) x ↔ Reducible r₁ x ∨ Reducible r₂ x := + exists_or + +theorem Normal.sup_iff (x : α) : Normal (r₁ ⊔ r₂) x ↔ Normal r₁ x ∧ Normal r₂ x := + (not_iff_not.mpr <| Reducible.sup_iff x).trans not_or + end Relation diff --git a/Cslib/Foundations/Relation/Defs.lean b/Cslib/Foundations/Relation/Defs.lean index 10e57bd42d..07a6980e14 100644 --- a/Cslib/Foundations/Relation/Defs.lean +++ b/Cslib/Foundations/Relation/Defs.lean @@ -35,8 +35,12 @@ def dom (r : α → β → Prop) : Set α := {a | ∃ b, r a b} /-- Codomain of a relation, aka range. -/ def cod (r : α → β → Prop) : Set β := {b | ∃ a, r a b} +/-- Generalisation of `Join` to two relations. -/ +def Join₂ (r₁ r₂ : α → α → Prop) (a b : α) : Prop := ∃ c, r₁ a c ∧ r₂ b c + /-- The join of the reflexive transitive closure. This is not named in Mathlib, but see `#loogle Relation.Join (Relation.ReflTransGen ?r)` -/ +@[deprecated "use `Join (ReflTrasnGen ·)` instead" (since := "2026-09-12")] abbrev MJoin (r : α → α → Prop) := Join (ReflTransGen r) /-- The relation `r` 'up to' the relation `s`. -/ @@ -51,8 +55,8 @@ def Preserves (r : α → α → Prop) (P : α → Prop) : Prop := ∀ ⦃a b⦄ abbrev Diamond (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join r b c /-- Generalization of `Diamond` to two relations. -/ -def DiamondCommute (r₁ r₂ : α → α → Prop) := - ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → ∃ z, r₂ y₁ z ∧ r₁ y₂ z +abbrev DiamondCommute (r₁ r₂ : α → α → Prop) := + ∀ {x y₁ y₂}, r₁ x y₁ → r₂ x y₂ → Join₂ r₂ r₁ y₁ y₂ /-- A relation is confluent when its reflexive transitive closure has the diamond property. -/ abbrev Confluent (r : α → α → Prop) := Diamond (ReflTransGen r) @@ -63,7 +67,11 @@ abbrev Commute (r₁ r₂ : α → α → Prop) := DiamondCommute (ReflTransGen /-- A relation is semi-confluent when single and multiple steps with common origin are multi-joinable. -/ abbrev SemiConfluent (r : α → α → Prop) := - ∀ {x y₁ y₂}, ReflTransGen r x y₂ → r x y₁ → Join (ReflTransGen r) y₁ y₂ + ∀ {x y₁ y₂}, r x y₁ → ReflTransGen r x y₂ → Join (ReflTransGen r) y₁ y₂ + +/-- Generalisation of `SemiConfluent` to two relations. -/ +abbrev SemiCommute (r₁ r₂ : α → α → Prop) := + ∀ {x y₁ y₂}, r₁ x y₁ → ReflTransGen r₂ x y₂ → Join₂ (ReflTransGen r₂) (ReflTransGen r₁) y₁ y₂ /-- A relation has the Church Rosser property when equivalence implies multi-joinability. -/ abbrev ChurchRosser (r : α → α → Prop) := ∀ {x y}, EqvGen r x y → Join (ReflTransGen r) x y @@ -72,6 +80,10 @@ abbrev ChurchRosser (r : α → α → Prop) := ∀ {x y}, EqvGen r x y → Join abbrev LocallyConfluent (r : α → α → Prop) := ∀ {a b c : α}, r a b → r a c → Join (ReflTransGen r) b c +/-- Generalization of `LocallyConfluent` to two relations. -/ +def LocallyCommute (r₁ r₂ : α → α → Prop) := + ∀ {a b c : α}, r₁ a b → r₂ a c → Join₂ (ReflTransGen r₂) (ReflTransGen r₁) b c + /-- A relation is strongly confluent when single steps are reflexive- and multi-joinable. -/ abbrev StronglyConfluent (r : α → α → Prop) := ∀ {x y₁ y₂}, r x y₁ → r x y₂ → ∃ z, ReflGen r y₁ z ∧ ReflTransGen r y₂ z diff --git a/Cslib/Foundations/Semantics/FLTS/Basic.lean b/Cslib/Foundations/Semantics/FLTS/Basic.lean index fcae4dcbe5..2a20e25e4f 100644 --- a/Cslib/Foundations/Semantics/FLTS/Basic.lean +++ b/Cslib/Foundations/Semantics/FLTS/Basic.lean @@ -53,6 +53,10 @@ theorem mtr_concat_eq {flts : FLTS State Label} {s : State} {μs : List Label} { flts.mtr s (μs ++ [μ]) = flts.tr (flts.mtr s μs) μ := by grind +theorem mtr_append_eq {flts : FLTS State Label} {s : State} {μs1 μs2 : List Label} : + flts.mtr s (μs1 ++ μs2) = flts.mtr (flts.mtr s μs1) μs2 := by + simp [mtr] + end FLTS end Cslib diff --git a/Cslib/Foundations/Semantics/LTS/HasTau.lean b/Cslib/Foundations/Semantics/LTS/HasTau.lean index 89643fdff6..1e28c9c9c4 100644 --- a/Cslib/Foundations/Semantics/LTS/HasTau.lean +++ b/Cslib/Foundations/Semantics/LTS/HasTau.lean @@ -80,11 +80,11 @@ theorem saturate_τsTr_τSTr_iff [hHasTau : HasTau Label] (lts : LTS State Label apply Iff.intro <;> intro h case mp => induction h - case refl => constructor + case refl => exact .refl case tail _ _ _ h2 h3 => exact Relation.ReflTransGen.trans h3 ((sTr_τSTr_iff _).mp h2) case mpr => cases h - case refl => constructor + case refl => exact .refl case tail s' h2 h3 => have h4 := STr.tr h2 h3 Relation.ReflTransGen.refl exact Relation.ReflTransGen.single h4 @@ -121,13 +121,13 @@ theorem saturate_tr_saturate_sTr [hHasTau : HasTau Label] (lts : LTS State Label apply Iff.intro <;> intro h case mp => cases h - case refl => constructor + case refl => exact .refl case tr hstr1 htr hstr2 => apply STr.single exact STr.tr hstr1 htr hstr2 case mpr => cases h - case refl => constructor + case refl => exact .refl case tr hstr1 htr hstr2 => rw [saturate_τsTr_τSTr_iff lts] at hstr1 hstr2 rw [←sTr_τSTr_iff lts] at hstr1 hstr2 diff --git a/Cslib/Languages/CCS/Basic.lean b/Cslib/Languages/CCS/Basic.lean index ec581611c2..3f338f046f 100644 --- a/Cslib/Languages/CCS/Basic.lean +++ b/Cslib/Languages/CCS/Basic.lean @@ -44,14 +44,60 @@ deriving DecidableEq /-- Processes. -/ inductive Process (Name : Type u) (Constant : Type v) : Type (max u v) where + /-- Terminated process. -/ | nil + /-- Do `μ` and proceed as `p`. -/ | pre (μ : Act Name) (p : Process Name Constant) + /-- `p` parallel `q`. -/ | par (p q : Process Name Constant) + /-- Do `p` or `q` (nondeterministically). -/ | choice (p q : Process Name Constant) + /-- Restriction. -/ | res (a : Name) (p : Process Name Constant) + /-- Constant. -/ | const (c : Constant) deriving DecidableEq +/-- Syntactic category for processes. -/ +declare_syntax_cat ccsProc + +@[inherit_doc Process.nil] +scoped syntax num : ccsProc + +@[inherit_doc Process.pre] +scoped syntax ident "." ccsProc : ccsProc + +@[inherit_doc Process.pre] +scoped syntax "(" term ")" "." ccsProc : ccsProc + +@[inherit_doc Process.choice] +scoped syntax ccsProc "+" ccsProc : ccsProc + +@[inherit_doc Process.par] +scoped syntax ccsProc "|" ccsProc : ccsProc + +@[inherit_doc Process.res] +scoped syntax "ν" term ccsProc : ccsProc + +@[inherit_doc Process.const] +scoped syntax "const" term : ccsProc + +@[inherit_doc Process] +scoped syntax "(" ccsProc ")" : ccsProc + +@[inherit_doc Process] +scoped syntax "`(CCS| " ccsProc ")" : term + +scoped macro_rules + | `(`(CCS| 0)) => `(Process.nil) + | `(`(CCS| $μ:ident . $p:ccsProc)) => `(Process.pre $μ `(CCS| $p)) + | `(`(CCS| ( $μ:term ) . $p:ccsProc)) => `(Process.pre $μ `(CCS| $p)) + | `(`(CCS| $p:ccsProc + $q:ccsProc)) => `(Process.choice `(CCS| $p) `(CCS| $q)) + | `(`(CCS| $p:ccsProc | $q:ccsProc)) => `(Process.par `(CCS| $p) `(CCS| $q)) + | `(`(CCS| ν $a:term $p:ccsProc)) => `(Process.res $a `(CCS| $p)) + | `(`(CCS| const $c:term)) => `(Process.const $c) + | `(`(CCS| ( $p:ccsProc ))) => `(`(CCS| $p)) + namespace Act /-- An action is visible if it a name or a coname. -/ @@ -151,7 +197,7 @@ theorem Context.complete (p : Process Name Constant) : obtain ⟨c, hc⟩ := ih exists res a c grind - case const k => + case «const» k => exists hole grind diff --git a/Cslib/Languages/CCS/BehaviouralTheory.lean b/Cslib/Languages/CCS/BehaviouralTheory.lean index f9684cddfc..d14dcb1651 100644 --- a/Cslib/Languages/CCS/BehaviouralTheory.lean +++ b/Cslib/Languages/CCS/BehaviouralTheory.lean @@ -193,7 +193,8 @@ open Bisimilarity in /-- P + Q ~ Q + P -/ theorem bisimilarity_choice_comm : (choice p q) ~[lts (defs := defs)] (choice q p) := by exists @ChoiceComm Name Constant defs - repeat constructor + constructor + · exact ChoiceComm.choiceComm intro s1 s2 hr μ cases hr case choiceComm p q => @@ -313,7 +314,7 @@ theorem bisimilarity_congr_choice : intro h exists @ChoiceBisim _ _ defs constructor - · constructor; assumption + · exact ChoiceBisim.choice h intro s1 s2 r μ constructor case left => diff --git a/Cslib/Languages/CCS/Semantics.lean b/Cslib/Languages/CCS/Semantics.lean index 93be9f5e87..788396ddf7 100644 --- a/Cslib/Languages/CCS/Semantics.lean +++ b/Cslib/Languages/CCS/Semantics.lean @@ -41,7 +41,7 @@ inductive Tr : Process Name Constant → Act Name → Process Name Constant → | choiceL : Tr p μ p' → Tr (choice p q) μ p' | choiceR : Tr q μ q' → Tr (choice p q) μ q' | res : μ ≠ Act.name a → μ ≠ Act.coname a → Tr p μ p' → Tr (res a p) μ (res a p') - | const : defs k = some p → Tr p μ p' → Tr (const k) μ p' + | const : defs k = some p → Tr p μ p' → Tr («const» k) μ p' instance : HasTau (Act Name) where τ := Act.τ @@ -69,10 +69,10 @@ theorem pre_tr (h : (lts (defs := defs)).Tr (pre μ p) μ' p') : μ = μ' ∧ p /-- Inversion lemma for constant transitions. -/ @[scoped grind →] -theorem const_tr (h : (lts (defs := defs)).Tr (const k) μ p') : +theorem const_tr (h : (lts (defs := defs)).Tr («const» k) μ p') : ∃ p, defs k = some p ∧ (lts (defs := defs)).Tr p μ p' := by cases h - case const p hdef htr => + case «const» p hdef htr => exists p /-- Prefixes are deterministic. -/ @@ -84,7 +84,7 @@ theorem pre_deterministicState : DeterministicState (lts (defs := defs)) (pre μ @[scoped grind .] theorem const_deterministicStateLabel (hdef : defs k = some p) (h : DeterministicStateLabel (lts (defs := defs)) p μ) : - DeterministicStateLabel (lts (defs := defs)) (const k) μ := by + DeterministicStateLabel (lts (defs := defs)) («const» k) μ := by intro p₁ p₂ h₁ h₂ cases h₁ cases h₂ diff --git a/Cslib/Languages/CombinatoryLogic/Basic.lean b/Cslib/Languages/CombinatoryLogic/Basic.lean index 579fb5aa41..04488c220f 100644 --- a/Cslib/Languages/CombinatoryLogic/Basic.lean +++ b/Cslib/Languages/CombinatoryLogic/Basic.lean @@ -223,7 +223,7 @@ theorem Y_def (f : SKI) : (Y ⬝ f) ↠ H ⬝ f ⬝ (H ⬝ f) := YPoly.toSKI_correct [f] (by simp) /-- The fixed-point property of the Y-combinator -/ -theorem Y_correct (f : SKI) : MJoin Red (Y ⬝ f) (f ⬝ (Y ⬝ f)) := by +theorem Y_correct (f : SKI) : Join (ReflTransGen Red) (Y ⬝ f) (f ⬝ (Y ⬝ f)) := by use f ⬝ (H ⬝ f ⬝ (H ⬝ f)) constructor · exact Trans.trans (Y_def f) (H_def f (H ⬝ f)) diff --git a/Cslib/Languages/CombinatoryLogic/Confluence.lean b/Cslib/Languages/CombinatoryLogic/Confluence.lean index 97c48458da..a59ea5cfc5 100644 --- a/Cslib/Languages/CombinatoryLogic/Confluence.lean +++ b/Cslib/Languages/CombinatoryLogic/Confluence.lean @@ -16,8 +16,8 @@ This file proves the **Church-Rosser** theorem for the SKI calculus, that is, if `a ↠ c`, `b ↠ d` and `c ↠ d` for some term `d`. More strongly (though equivalently), we show that the relation of having a common reduct is transitive — in the above situation, `a` and `b`, and `a` and `c` have common reducts, so the result implies the same of `b` and `c`. Note that -`MJoin Red` is symmetric (trivially) and reflexive (since `↠` is), so we in fact show that -`MJoin Red` is an equivalence. +`Join (ReflTransGen Red)` is symmetric (trivially) and reflexive (since `↠` is), so we in fact show +that `Join (ReflTransGen Red)` is an equivalence. Our proof follows the method of Tait and Martin-Löf for the lambda calculus, as presented for instance in @@ -33,7 +33,7 @@ reduction on the head and tail of a term. - `parallelReduction_diamond` : parallel reduction satisfies the diamond property, that is, it is confluent in a single step. -- `mJoin_red_equivalence` : by a general result, the diamond property for `⭢ₚ` implies the same +- `join_mRed_equivalence` : by a general result, the diamond property for `⭢ₚ` implies the same for its reflexive-transitive closure. This closure is exactly `↠`, which implies the **Church-Rosser** theorem as sketched above. -/ @@ -205,20 +205,20 @@ theorem parallelReduction_diamond : Diamond ParallelReduction := by case red_S => exact ⟨a ⬝ c ⬝ (b ⬝ c), .refl _, .refl _,⟩ theorem join_parallelReduction_equivalence : - Equivalence (MJoin ParallelReduction) := + Equivalence (Join (ReflTransGen ParallelReduction)) := Confluent.equivalence_join_reflTransGen <| Diamond.to_confluent parallelReduction_diamond /-- The **Church-Rosser** theorem in its general form. -/ -theorem mJoin_red_equivalence : Equivalence (MJoin Red) := by - rw [MJoin, ←reflTransGen_parallelReduction_mRed] +theorem join_mRed_equivalence : Equivalence (Join (ReflTransGen Red)) := by + rw [←reflTransGen_parallelReduction_mRed] exact join_parallelReduction_equivalence /-- The **Church-Rosser** theorem in the form it is usually stated. -/ theorem MRed.diamond : Confluent Red := by intro a b c hab hac - apply mJoin_red_equivalence.trans (y := a) - · exact mJoin_red_equivalence.symm (MJoin.single hab) - · exact MJoin.single hac + apply join_mRed_equivalence.trans (y := a) + · exact join_mRed_equivalence.symm (Join.single hab) + · exact Join.single hac end SKI diff --git a/Cslib/Languages/CombinatoryLogic/Defs.lean b/Cslib/Languages/CombinatoryLogic/Defs.lean index 7d028d2834..ea8aedce71 100644 --- a/Cslib/Languages/CombinatoryLogic/Defs.lean +++ b/Cslib/Languages/CombinatoryLogic/Defs.lean @@ -113,12 +113,18 @@ lemma parallel_mRed {a a' b b' : SKI} (ha : a ↠ a') (hb : b ↠ b') : lemma parallel_red {a a' b b' : SKI} (ha : a ⭢ a') (hb : b ⭢ b') : (a ⬝ b) ↠ (a' ⬝ b') := by trans a' ⬝ b <;> grind -theorem mJoin_red_head {x x' : SKI} (y : SKI) : MJoin Red x x' → MJoin Red (x ⬝ y) (x' ⬝ y) +theorem join_mRed_head {x x' : SKI} (y : SKI) : + Join (ReflTransGen Red) x x' → Join (ReflTransGen Red) (x ⬝ y) (x' ⬝ y) | ⟨z, hz, hz'⟩ => ⟨z ⬝ y, MRed.head y hz, MRed.head y hz'⟩ -theorem mJoin_red_tail (x : SKI) {y y' : SKI} : MJoin Red y y' → MJoin Red (x ⬝ y) (x ⬝ y') +@[deprecated (since := "2026-09-12")] alias mJoin_red_head := join_mRed_head + +theorem join_mRed_tail (x : SKI) {y y' : SKI} : + Join (ReflTransGen Red) y y' → Join (ReflTransGen Red) (x ⬝ y) (x ⬝ y') | ⟨z, hz, hz'⟩ => ⟨x ⬝ z, MRed.tail x hz, MRed.tail x hz'⟩ +@[deprecated (since := "2026-09-12")] alias mJoin_red_tail := join_mRed_tail + end SKI end Cslib diff --git a/Cslib/Languages/CombinatoryLogic/Evaluation.lean b/Cslib/Languages/CombinatoryLogic/Evaluation.lean index 8971eebe84..f2fa26a80e 100644 --- a/Cslib/Languages/CombinatoryLogic/Evaluation.lean +++ b/Cslib/Languages/CombinatoryLogic/Evaluation.lean @@ -178,10 +178,13 @@ theorem redexFree_iff_mred_eq {x : SKI} : x.RedexFree ↔ ∀ y, (x ↠ y) ↔ x exact Red.ne hy (h.1 (Relation.ReflTransGen.single hy)) /-- If a term has a common reduct with a normal term, it in fact reduces to that term. -/ -theorem mJoin_red_redexFree {x y : SKI} (hy : y.RedexFree) (h : MJoin Red x y) : x ↠ y := +theorem join_mRed_redexFree {x y : SKI} (hy : y.RedexFree) (h : Join (ReflTransGen Red) x y) : + x ↠ y := let ⟨w, hyw, hzw⟩ := h (redexFree_iff_mred_eq.1 hy _ |>.1 hzw : y = w) ▸ hyw +@[deprecated (since := "2026-09-12")] alias mJoin_red_redexFree := join_mRed_redexFree + /-- If `x` reduces to both `y` and `z`, and `z` is not reducible, then `y` reduces to `z`. -/ lemma confluent_redexFree {x y z : SKI} (hxy : x ↠ y) (hxz : x ↠ z) (hz : RedexFree z) : y ↠ z := let ⟨w, hyw, hzw⟩ := MRed.diamond hxy hxz @@ -195,13 +198,16 @@ lemma unique_normal_form {x y z : SKI} (redexFree_iff_mred_eq.1 hy _).1 (confluent_redexFree hxy hxz hz) /-- If `x` and `y` are normal and have a common reduct, then they are equal. -/ -lemma eq_of_mJoin_red_redexFree {x y : SKI} (h : MJoin Red x y) +lemma eq_of_join_mRed_redexFree {x y : SKI} (h : Join (ReflTransGen Red) x y) (hx : x.RedexFree) (hy : y.RedexFree) : x = y := - (redexFree_iff_mred_eq.1 hx _).1 (mJoin_red_redexFree hy h) + (redexFree_iff_mred_eq.1 hx _).1 (join_mRed_redexFree hy h) + +@[deprecated (since := "2026-09-12")] alias eq_of_mJoin_red_redexFree := eq_of_join_mRed_redexFree + /-! ### Injectivity for datatypes -/ -lemma sk_nequiv : ¬ MJoin Red S K := by +lemma sk_nequiv : ¬ Join (ReflTransGen Red) S K := by intro ⟨z, hsz, hkz⟩ have hS : RedexFree S := by simp [RedexFree] have hK : RedexFree K := by simp [RedexFree] @@ -210,19 +216,19 @@ lemma sk_nequiv : ¬ MJoin Red S K := by /-- Injectivity for booleans. -/ theorem isBool_injective (x y : SKI) (u v : Bool) (hx : IsBool u x) (hy : IsBool v y) - (hxy : MJoin Red x y) : u = v := by - have h : MJoin Red (if u then S else K) (if v then S else K) := by - apply mJoin_red_equivalence.trans (y := x ⬝ S ⬝ K) - · apply mJoin_red_equivalence.symm - apply Relation.MJoin.single + (hxy : Join (ReflTransGen Red) x y) : u = v := by + have h : Join (ReflTransGen Red) (if u then S else K) (if v then S else K) := by + apply join_mRed_equivalence.trans (y := x ⬝ S ⬝ K) + · apply join_mRed_equivalence.symm + apply Relation.Join.single exact hx S K - · apply mJoin_red_equivalence.trans (y := y ⬝ S ⬝ K) - · exact mJoin_red_head K <| mJoin_red_head S hxy - · apply Relation.MJoin.single + · apply join_mRed_equivalence.trans (y := y ⬝ S ⬝ K) + · exact join_mRed_head K <| join_mRed_head S hxy + · apply Relation.Join.single exact hy S K - grind [sk_nequiv, mJoin_red_equivalence.symm h] + grind [sk_nequiv, join_mRed_equivalence.symm h] -lemma TF_nequiv : ¬ MJoin Red TT FF := fun h => +lemma TF_nequiv : ¬ Join (ReflTransGen Red) TT FF := fun h => (Bool.eq_not_self true).mp <| isBool_injective TT FF true false TT_correct FF_correct h /-- A specialisation of `Church : Nat → SKI`. -/ @@ -248,17 +254,17 @@ lemma churchK_injective : Function.Injective churchK := /-- Injectivity for Church numerals -/ theorem isChurch_injective (x y : SKI) (n m : Nat) (hx : IsChurch n x) (hy : IsChurch m y) - (hxy : MJoin Red x y) : n = m := by - suffices MJoin Red (churchK n) (churchK m) by + (hxy : Join (ReflTransGen Red) x y) : n = m := by + suffices Join (ReflTransGen Red) (churchK n) (churchK m) by apply churchK_injective - exact eq_of_mJoin_red_redexFree this (churchK_redexFree n) (churchK_redexFree m) - apply mJoin_red_equivalence.trans (y := x ⬝ K ⬝ K) + exact eq_of_join_mRed_redexFree this (churchK_redexFree n) (churchK_redexFree m) + apply join_mRed_equivalence.trans (y := x ⬝ K ⬝ K) · simp_rw [churchK_church] - exact mJoin_red_equivalence.symm <| Relation.MJoin.single (hx K K) - · apply mJoin_red_equivalence.trans (y := y ⬝ K ⬝ K) - · apply mJoin_red_head; apply mJoin_red_head; assumption + exact join_mRed_equivalence.symm <| Relation.Join.single (hx K K) + · apply join_mRed_equivalence.trans (y := y ⬝ K ⬝ K) + · apply join_mRed_head; apply join_mRed_head; assumption · simp_rw [churchK_church] - exact Relation.MJoin.single (hy K K) + exact Relation.Join.single (hy K K) /-- **Rice's theorem**: no SKI term is a non-trivial predicate. diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean index 5e3187c3f7..3a9a2d19bb 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/FullBetaConfluence.lean @@ -91,7 +91,7 @@ lemma Parallel.le_reflTransGen_fullBeta : ((· ⭢ₚ ·) : Term Var → Term Var → Prop) ≤ (· ↠βᶠ ·) := by intro M N para induction para - case fvar => constructor + case fvar => exact .refl case app L L' R R' l_para m_para redex_l redex_m => have : L.app R ↠βᶠ L'.app R := by grind grind [ReflTransGen.trans] diff --git a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean index 6281078210..85ade08028 100644 --- a/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean +++ b/Cslib/Languages/LambdaCalculus/LocallyNameless/Untyped/StandardReduction.lean @@ -65,7 +65,7 @@ lemma Standard.lc_l (step : M ⭢ₛ N) : LC M := by /-- Standard reduction is reflexive for locally closed terms. -/ lemma Standard.lc_refl (M : Term Var) (lc : LC M) : M ⭢ₛ M := by induction lc - all_goals constructor <;> assumption + all_goals constructor! <;> assumption /-- The right side of a standard reduction is locally closed. -/ lemma Standard.lc_r (step : M ⭢ₛ N) : LC N := by diff --git a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean index e1051929fc..89bea80d0d 100644 --- a/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean +++ b/Cslib/Logics/LinearLogic/CLL/PhaseSemantics/Basic.lean @@ -154,7 +154,7 @@ instance : SetLike (Fact P) P where coe := Fact.carrier coe_injective _ _ _ := by grind only [cases Fact] -instance : PartialOrder (Fact P) := PartialOrder.ofSetLike (Fact P) P +instance : PartialOrder (Fact P) := PartialOrder.ofSetLike (Fact P) instance : HasSubset (Fact P) := ⟨fun A B => (A : Set P) ⊆ (B : Set P)⟩ diff --git a/Cslib/MachineLearning/PACLearning/VersionSpace.lean b/Cslib/MachineLearning/PACLearning/VersionSpace.lean index 7423f1fb8f..753d80f80e 100644 --- a/Cslib/MachineLearning/PACLearning/VersionSpace.lean +++ b/Cslib/MachineLearning/PACLearning/VersionSpace.lean @@ -21,8 +21,8 @@ Angluin (1980). - `VersionSpace C S`: the subset of `C` whose concepts agree with `S` on every sample point. -- `IsConsistent A C`: a learner is consistent with `C` if its output always lies - in the version space at the received sample. +- `IsConsistent A C`: a learner is consistent with `C` if its output lies in + the version space at every realizable sample. - `empiricalMiscount h S`: number of sample points where `h` errs (`[DecidableEq β]`). - `empiricalMeasure S`: the uniform Dirac mixture over the sample. - `empiricalError h S`: the empirical distribution's mass on the disagreement set. @@ -35,7 +35,7 @@ Angluin (1980). - `mem_versionSpace_iff_empiricalMiscount_zero`: combinatorial bridge. - `mem_versionSpace_iff_empiricalError_zero`: measure-theoretic bridge. - `IsConsistent.empiricalMiscount_eq_zero`, `IsConsistent.empiricalError_eq_zero`: - consistent learners achieve zero error / miscount on every sample. + consistent learners achieve zero error / miscount on every realizable sample. - `mem_versionSpace_of_realizable`, `Realizable.versionSpace_nonempty`: realizable samples give non-empty version spaces. - `ae_mem_versionSpace_of_realizable`: under iid sampling from a realizable @@ -169,49 +169,52 @@ theorem empiricalError_eq_div [DecidableEq β] simp only [Measure.dirac_apply, Set.indicator, Set.mem_ofPred_eq, Pi.one_apply, smul_eq_mul] rw [Finset.sum_boole, ← ENNReal.div_eq_inv_mul] +/-! ### Realizable Samples -/ + +/-- A labeled sample `S` is *realizable* by concept class `C` if some concept +in `C` labels every sample point correctly. -/ +def Realizable {m : ℕ} (C : ConceptClass α β) (S : LabeledSample α β m) : Prop := + ∃ c ∈ C, ∀ i : Fin m, (S i).2 = c (S i).1 + /-! ### Consistent Learners -/ -/-- A learner is *consistent* with the concept class `C` if, on every labeled -sample it receives, its output hypothesis lies in the version space of `C` at -that sample — i.e. the output is in `C` and agrees with every observed -labeled pair. -/ +/-- A learner is *consistent* with the concept class `C` if, on every sample +realizable by `C`, its output hypothesis lies in the version space of `C` at +that sample — i.e. the output is in `C` and agrees with every observed labeled +pair. No condition is imposed on samples that no concept in `C` can realize. -/ def IsConsistent {m : ℕ} (A : Learner α β m) (C : ConceptClass α β) : Prop := - ∀ S : LabeledSample α β m, A S ∈ VersionSpace C S + ∀ S : LabeledSample α β m, Realizable C S → A S ∈ VersionSpace C S -/-- A consistent learner's output is always in the concept class. -/ +/-- A consistent learner's output is in the concept class on every realizable sample. -/ theorem IsConsistent.output_mem_conceptClass {m : ℕ} {A : Learner α β m} - {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m) : - A S ∈ C := (hA S).1 + {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m) + (hS : Realizable C S) : + A S ∈ C := (hA S hS).1 -/-- A consistent learner's output agrees with the sample on every observed -point. -/ +/-- On every realizable sample, a consistent learner's output agrees with +every observed point. -/ theorem IsConsistent.output_agrees {m : ℕ} {A : Learner α β m} {C : ConceptClass α β} (hA : IsConsistent A C) (S : LabeledSample α β m) - (i : Fin m) : - A S (S i).1 = (S i).2 := (hA S).2 i + (hS : Realizable C S) (i : Fin m) : + A S (S i).1 = (S i).2 := (hA S hS).2 i -/-- A consistent learner has zero empirical miscount on every sample. -/ +/-- A consistent learner has zero empirical miscount on every realizable sample. -/ theorem IsConsistent.empiricalMiscount_eq_zero [DecidableEq β] {m : ℕ} {A : Learner α β m} {C : ConceptClass α β} (hA : IsConsistent A C) - (S : LabeledSample α β m) : + (S : LabeledSample α β m) (hS : Realizable C S) : empiricalMiscount (A S) S = 0 := - (mem_versionSpace_iff_empiricalMiscount_zero.mp (hA S)).2 + (mem_versionSpace_iff_empiricalMiscount_zero.mp (hA S hS)).2 -/-- A consistent learner has zero empirical error on every sample. -/ +/-- A consistent learner has zero empirical error on every realizable sample. -/ theorem IsConsistent.empiricalError_eq_zero [MeasurableSpace α] [MeasurableSpace β] [MeasurableSingletonClass α] [MeasurableSingletonClass β] {m : ℕ} {A : Learner α β m} {C : ConceptClass α β} - (hA : IsConsistent A C) (S : LabeledSample α β m) : + (hA : IsConsistent A C) (S : LabeledSample α β m) (hS : Realizable C S) : empiricalError (A S) S = 0 := - (mem_versionSpace_iff_empiricalError_zero.mp (hA S)).2 - -/-! ### Realizable case -/ + (mem_versionSpace_iff_empiricalError_zero.mp (hA S hS)).2 -/-- A labeled sample `S` is *realizable* by concept class `C` if some concept -in `C` labels every sample point correctly. -/ -def Realizable {m : ℕ} (C : ConceptClass α β) (S : LabeledSample α β m) : Prop := - ∃ c ∈ C, ∀ i : Fin m, (S i).2 = c (S i).1 +/-! ### Realizable Version Spaces -/ /-- *Realizable version-space nonemptiness.* If a target concept `c` lies in `C` and the sample `S` is labeled by `c` (i.e. every `(S i).2 = c (S i).1`), diff --git a/CslibTests.lean b/CslibTests.lean index f7b53299f6..ee14990d3d 100644 --- a/CslibTests.lean +++ b/CslibTests.lean @@ -1,9 +1,12 @@ import CslibTests.Bisimulation +import CslibTests.BooleanCircuits import CslibTests.CCS import CslibTests.CCS.VendingMachine import CslibTests.CLL +import CslibTests.CircuitCounting import CslibTests.Circuits import CslibTests.Commitment +import CslibTests.Complexity.Combinators import CslibTests.Congruence import CslibTests.DFA import CslibTests.FreeMonad @@ -21,5 +24,7 @@ import CslibTests.Modal import CslibTests.Modal.Ideal import CslibTests.Modal.Stlc import CslibTests.MultiTapeComplexity +import CslibTests.PACLearning import CslibTests.Reduction import CslibTests.StatefulProcesses +import CslibTests.Synthesis diff --git a/CslibTests/BooleanCircuits.lean b/CslibTests/BooleanCircuits.lean new file mode 100644 index 0000000000..6a85453479 --- /dev/null +++ b/CslibTests/BooleanCircuits.lean @@ -0,0 +1,72 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.Computability.Circuit.Boolean.Counting +import Cslib.Computability.Circuit.Boolean.Lupanov +import Cslib.Computability.Circuit.Boolean.Shannon + +/-! +# Boolean circuit tests + +Zero-input constants, zero-gate projections, shared outputs, and compatibility of the +Shannon and Lupanov bounds. +-/ + +namespace CslibTests.BooleanCircuits + +open Cslib.Circuits Cslib.Circuits.Boolean + +example (value : Bool) : + ∃ g ≤ 1, ∃ c : Circuit signature 0 g 1, c.Computes interpretation (fun _ => value) := + (Synthesis.const (s := inputs 0) value).exists_circuit + +example {n : ℕ} (i : Fin n) : + ∃ g ≤ 0, ∃ c : Circuit signature n g 1, c.Computes interpretation (fun x => x i) := by + have h : Synthesis interpretation (inputs n) {fun x => x i} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨i, rfl⟩) + exact h.exists_circuit + +example : ¬ (Circuit.id signature 1).Computes interpretation (fun x => !x 0) := by + intro h + have := h (fun _ => true) + simp at this + +private def conjunction : BooleanFunction 2 := fun x => x 0 && x 1 + +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 2, + ∀ x, c.eval interpretation x 0 = conjunction x ∧ + c.eval interpretation x 1 = !conjunction x := by + have hand : Synthesis interpretation (inputs 2) {conjunction} 1 := + Synthesis.gate (I := interpretation) .and (fun i x => x i) (fun i => ⟨i, rfl⟩) + have hkeep : Synthesis interpretation (inputs 2 ∪ {conjunction}) {conjunction} 0 := + Synthesis.of_subset Set.subset_union_right + have h := hand.comp (hkeep.union hkeep.not) + have hout : Synthesis interpretation (inputs 2) + (Set.range fun i : Fin 2 => if i = 0 then conjunction else fun x => !conjunction x) 2 := + h.mono Set.Subset.rfl (by rintro _ ⟨i, rfl⟩; dsimp only; split <;> simp) le_rfl + obtain ⟨g, hg, c, hc⟩ := hout.exists_circuit_family + exact ⟨g, hg, c, fun x => ⟨by simpa using hc x 0, by simpa using hc x 1⟩⟩ + +example : computableFunctions 0 0 = ∅ := by + apply Finset.card_eq_zero.mp + simpa using card_computableFunctions_mul_factorial_le 0 0 + +example : (fun x : Fin 1 → Bool => x 0) ∈ computableFunctions 1 0 := by + exact mem_computableFunctions.mpr ⟨0, le_rfl, Circuit.id signature 1, by intro x; rfl⟩ + +example (ε : ℝ) (hε : 0 < ε) : + ∃ N : ℕ, ∀ n ≥ N, ∃ f : BooleanFunction n, + (∀ {g} (c : Circuit signature n g 1), + c.Computes interpretation f → 2 ^ n / (n : ℝ) < (c.size : ℝ)) ∧ + ∃ g, ∃ c : Circuit signature n g 1, + c.Computes interpretation f ∧ (c.size : ℝ) ≤ (1 + ε) * 2 ^ n / n := by + obtain ⟨N, hN⟩ := Shannon.exists_hard_function + obtain ⟨M, hM⟩ := Lupanov.exists_circuit ε hε + refine ⟨max N M, fun n hn => ?_⟩ + obtain ⟨f, hf⟩ := hN n ((le_max_left N M).trans hn) + exact ⟨f, hf, hM n ((le_max_right N M).trans hn) f⟩ + +end CslibTests.BooleanCircuits diff --git a/CslibTests/CCS/VendingMachine.lean b/CslibTests/CCS/VendingMachine.lean index 7771ec301a..285f8b2c9c 100644 --- a/CslibTests/CCS/VendingMachine.lean +++ b/CslibTests/CCS/VendingMachine.lean @@ -11,7 +11,7 @@ namespace CslibTests open Cslib CCS Process Algorithms.CCS.VendingMachine /-- The deterministic vending machine can perform a coin action. -/ -example : ltsD.Tr vm Coin (choice (pre Tea (const .vm)) (pre Coffee (const .vm))) := +example : ltsD.Tr vm Coin `(CCS| (Tea. const .vm) + (Coffee. const .vm)) := Tr.const rfl Tr.pre end CslibTests diff --git a/CslibTests/CircuitCounting.lean b/CslibTests/CircuitCounting.lean new file mode 100644 index 0000000000..dbc70fdd4c --- /dev/null +++ b/CslibTests/CircuitCounting.lean @@ -0,0 +1,120 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.Computability.Circuit.Shannon +import Mathlib.Data.Fintype.Sum +import Mathlib.Tactic.DeriveFintype + +/-! +# Generic circuit counting tests + +These tests exercise computable syntax enumeration, semantic counting on an infinite carrier, +normalization of distinct symbols with the same interpretation, and empty or nullary signatures. +The Shannon theorem is also instantiated on the NAND basis and a three-valued carrier. +-/ + +namespace CslibTests.CircuitCounting + +open Cslib.Circuits + +inductive ArithmeticOp where + | zero (tag : Bool) + | add + deriving DecidableEq, Fintype + +abbrev arithmeticSignature : Signature where + Op := ArithmeticOp + Arity + | .zero _ => 0 + | .add => 2 + +def arithmeticInterpretation : Interpretation arithmeticSignature ℕ + | .zero _, _ => 0 + | .add, input => input 0 + input 1 + +-- Syntax enumeration computes even with no input wires and operations of mixed arities. +example : Fintype.card (Line arithmeticSignature 0 0) = 2 := by decide +example : Fintype.card (Line arithmeticSignature 2 1) = 11 := by decide +example : Fintype.card (Program arithmeticSignature 0 2) = 6 := by decide +example : Fintype.card (Circuit arithmeticSignature 0 0 0) = 1 := by decide +example : Fintype.card (Circuit arithmeticSignature 0 0 1) = 0 := by decide + +def addition : Circuit arithmeticSignature 2 1 1 where + program := .gate .empty ⟨.add, fun i => Wire.input i⟩ + outputs := fun _ => Wire.gate 0 + +example : (fun x => x 0 + x 1) ∈ computableFunctions arithmeticInterpretation 2 1 := + (mem_computableFunctions (I := arithmeticInterpretation)).mpr + ⟨1, le_rfl, addition, fun _ => rfl⟩ + +def redundant : Circuit arithmeticSignature 0 2 2 where + program := .gate (.gate .empty ⟨.zero false, Fin.elim0⟩) ⟨.zero true, Fin.elim0⟩ + outputs := Wire.gate + +example : ¬ redundant.Irredundant arithmeticInterpretation := by + intro h + have : (0 : Fin 2) = 1 := h (by rfl) + contradiction + +-- Normalization preserves all outputs together over the infinite carrier. +example : ∃ k ≤ 2, ∃ c : Circuit arithmeticSignature 0 k 2, + (∀ x j, c.eval arithmeticInterpretation x j = 0) ∧ + c.Irredundant arithmeticInterpretation := by + obtain ⟨k, hk, c, hc, hi⟩ := redundant.exists_irredundant arithmeticInterpretation + refine ⟨k, hk, c, ?_, hi⟩ + intro x j + rw [hc] + fin_cases j <;> rfl + +abbrev emptySignature : Signature where + Op := Empty + Arity := Empty.elim + +def emptyInterpretation : Interpretation emptySignature ℕ := fun op => nomatch op + +example : Fintype.card (Program emptySignature 1 1) = 0 := by decide + +example : (fun x : Fin 1 → ℕ => x 0) ∈ computableFunctions emptyInterpretation 1 0 := + (mem_computableFunctions (I := emptyInterpretation)).mpr + ⟨0, le_rfl, Circuit.id emptySignature 1, fun _ => rfl⟩ + +example (s : ℕ) : (computableFunctions emptyInterpretation 0 s).card * s.factorial ≤ + (s + 1) * s ^ s * s := by + simpa using card_computableFunctions_mul_factorial_le_of_arity_le emptyInterpretation + 0 s 0 (fun op => nomatch op) + +abbrev nullarySignature : Signature where + Op := Unit + Arity := fun _ => 0 + +def nullaryInterpretation : Interpretation nullarySignature ℕ := fun _ _ => 0 + +example (s : ℕ) : (computableFunctions nullaryInterpretation 0 s).card * s.factorial ≤ + (s + 1) * (max s 1) ^ s * s := by + simpa using card_computableFunctions_mul_factorial_le_of_arity_le nullaryInterpretation + 0 s 0 (fun _ => le_rfl) + +abbrev binarySignature : Signature where + Op := Unit + Arity := fun _ => 2 + +def nandInterpretation : Interpretation binarySignature Bool := fun _ x => !(x 0 && x 1) + +example : ∃ N : ℕ, ∀ n ≥ N, ∃ f : (Fin n → Bool) → Bool, + ∀ {g} (c : Circuit binarySignature n g 1), + c.Computes nandInterpretation f → 2 ^ n / (n : ℝ) < (c.size : ℝ) := by + simpa [Nat.card_eq_fintype_card] using + Shannon.exists_hard_function nandInterpretation (fun _ => le_rfl) + +def ternaryInterpretation : Interpretation binarySignature (Fin 3) := fun _ x => x 0 + x 1 + +example : ∃ N : ℕ, ∀ n ≥ N, ∃ f : (Fin n → Fin 3) → Fin 3, + ∀ {g} (c : Circuit binarySignature n g 1), + c.Computes ternaryInterpretation f → 3 ^ n / (n : ℝ) < (c.size : ℝ) := by + simpa [Nat.card_eq_fintype_card] using + Shannon.exists_hard_function ternaryInterpretation (fun _ => le_rfl) + +end CslibTests.CircuitCounting diff --git a/CslibTests/Complexity/Combinators.lean b/CslibTests/Complexity/Combinators.lean new file mode 100644 index 0000000000..b4c3a05a7b --- /dev/null +++ b/CslibTests/Complexity/Combinators.lean @@ -0,0 +1,38 @@ +/- +Copyright (c) 2026 Christian Reitwiessner. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Christian Reitwiessner +-/ + +import Cslib.Computability.Machines.Turing.MultiTape.Combinators.AlmostConstant + +namespace CslibTests + +open Cslib Turing MultiTapeTM + +/-- The Boolean `and` function is computable in constant time and zero space. -/ +example : ∀ encIn encOut, ∃ c, ComputableInTimeAndSpace + (Function.uncurry Bool.and) encIn encOut (fun _ => c) (fun _ => 0) := by + intro encIn encOut + apply computableInTimeAndSpace_of_finite + +def fullAdder (a b carry : Bool) : Bool × Bool := + let sum := (a != b) != carry + let newCarry := (a && b) || (carry && (a != b)) + (sum, newCarry) + +/-- The binary full adder is computable in constant time and zero space. -/ +example : ∀ encIn encOut, ∃ c, ComputableInTimeAndSpace + (fun (a, b, carry) => fullAdder a b carry) encIn encOut (fun _ => c) (fun _ => 0) := by + intro encIn encOut + apply computableInTimeAndSpace_of_finite + +/-- Equality comparison to a constant is computable in constant time and zero space, +also for infinite domains. -/ +example {α : Type*} [DecidableEq α] : ∀ encIn encOut out, ∃ c, ComputableInTimeAndSpace + (fun a : α => a == out) encIn encOut (fun _ => c) (fun _ => 0) := by + intro encIn encOut out + refine computableInTimeAndSpace_of_exists_finite_ne ⟨false, ?_⟩ + exact Set.Finite.subset (Set.finite_singleton out) (by intro a ha; simp_all) + +end CslibTests diff --git a/CslibTests/PACLearning.lean b/CslibTests/PACLearning.lean new file mode 100644 index 0000000000..2156a645e0 --- /dev/null +++ b/CslibTests/PACLearning.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.MachineLearning.PACLearning.VersionSpace + +namespace CslibTests.PACLearning + +open Cslib.MachineLearning.PACLearning + +/-- A learner on two samples over a singleton domain that predicts the first label. -/ +def firstLabelLearner : Learner Unit Bool 2 := + fun S _ => (S 0).2 + +/-- Two different labels for the same point form an unrealizable sample. -/ +def contradictorySample : LabeledSample Unit Bool 2 := + fun i => if i = 0 then ((), false) else ((), true) + +theorem contradictorySample_not_realizable : + ¬ Realizable (Set.univ : ConceptClass Unit Bool) contradictorySample := by + rintro ⟨c, _, hc⟩ + simpa [contradictorySample] using + (hc (0 : Fin 2)).trans (hc (1 : Fin 2)).symm + +/-- Regression: consistency does not require a learner to fit an unrealizable +contradictory sample. -/ +theorem firstLabelLearner_consistent : + IsConsistent firstLabelLearner (Set.univ : ConceptClass Unit Bool) := by + intro S hS + obtain ⟨c, _, hc⟩ := hS + rw [mem_versionSpace_iff] + refine ⟨Set.mem_univ _, fun i => ?_⟩ + change (S 0).2 = (S i).2 + calc + (S 0).2 = c (S 0).1 := hc 0 + _ = c (S i).1 := congrArg c (Subsingleton.elim _ _) + _ = (S i).2 := (hc i).symm + +example : + firstLabelLearner contradictorySample (contradictorySample 1).1 ≠ + (contradictorySample 1).2 := by + simp [firstLabelLearner, contradictorySample] + +/-- A realizable sample used to guard the positive consistency guarantee. -/ +def constantTrueSample : LabeledSample Unit Bool 2 := + fun _ => ((), true) + +theorem constantTrueSample_realizable : + Realizable (Set.univ : ConceptClass Unit Bool) constantTrueSample := by + refine ⟨fun _ => true, Set.mem_univ _, ?_⟩ + intro i + rfl + +example (i : Fin 2) : + firstLabelLearner constantTrueSample (constantTrueSample i).1 = + (constantTrueSample i).2 := + firstLabelLearner_consistent.output_agrees + constantTrueSample constantTrueSample_realizable i + +end CslibTests.PACLearning diff --git a/CslibTests/StatefulProcesses.lean b/CslibTests/StatefulProcesses.lean index 292a4cf794..f028381dc4 100644 --- a/CslibTests/StatefulProcesses.lean +++ b/CslibTests/StatefulProcesses.lean @@ -63,7 +63,7 @@ def helloLts : LTS HelloCfg (Cfg.TrLabel String String String) := Cfg.lts string -- This is begging for more automation. example : helloLts.Tr helloCfg (.com "p" "q" "Hello") (Cfg.mk 0 (helloCfg.store[("q", "x") := "Hello"])) := by - apply Cfg.Tr.com (heval := by constructor) (hstore := rfl) + apply Cfg.Tr.com (heval := FunCallEval.EvalExpr.val) (hstore := rfl) apply Network.Tr.com (by constructor) (by constructor) ext p simp only [Pi.zero_apply, helloCfg, HasSubstitution.subst] diff --git a/CslibTests/Synthesis.lean b/CslibTests/Synthesis.lean new file mode 100644 index 0000000000..de05f17184 --- /dev/null +++ b/CslibTests/Synthesis.lean @@ -0,0 +1,126 @@ +/- +Copyright (c) 2026 Samuel Schlesinger. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Samuel Schlesinger +-/ + +import Cslib.Computability.Circuit.Synthesis +import Mathlib.Data.Fintype.Card + +/-! +# Generic synthesis tests + +These examples use arbitrary carriers and an infinite arithmetic signature with unbounded +arities. They exercise shared outputs, ordered and unordered folds, and empty constructions. +-/ + +namespace CslibTests.Synthesis + +open Cslib.Circuits + +universe v u + +example {σ : Signature.{v}} {U : Type u} (I : Interpretation σ U) {n : ℕ} (i : Fin n) : + ∃ g ≤ 0, ∃ c : Circuit σ n g 1, c.Computes I (fun x => x i) := by + have h : Synthesis I (inputs n) {fun x => x i} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨i, rfl⟩) + exact h.exists_circuit + +example {σ : Signature.{v}} {U : Type u} (I : Interpretation σ U) : + ∃ g ≤ 0, ∃ c : Circuit σ 0 g 0, ∀ x j, c.eval I x j = Fin.elim0 j := by + have h : Synthesis I (inputs 0) (Set.range fun (j : Fin 0) (_ : Fin 0 → U) => Fin.elim0 j) + 0 := Synthesis.of_subset (by rintro _ ⟨j, rfl⟩; exact Fin.elim0 j) + exact h.exists_circuit_family + +inductive Op where + | const (value : ℕ) + | add + | mul + | sub + | total (arity : ℕ) + +abbrev signature : Signature where + Op := Op + Arity + | .const _ => 0 + | .add | .mul | .sub => 2 + | .total k => k + +def interpretation : Interpretation signature ℕ + | .const value, _ => value + | .add, x => x 0 + x 1 + | .mul, x => x 0 * x 1 + | .sub, x => x 0 - x 1 + | .total _, x => ∑ i, x i + +private theorem projection {n : ℕ} (i : Fin n) : + Synthesis interpretation (inputs n) {fun x => x i} 0 := + Synthesis.of_subset (Set.singleton_subset_iff.mpr ⟨i, rfl⟩) + +private theorem add_available {n : ℕ} (f g : (Fin n → ℕ) → ℕ) : + Synthesis interpretation {f, g} {fun x => f x + g x} 1 := by + simpa [interpretation] using Synthesis.gate (I := interpretation) (s := {f, g}) .add + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + +private theorem sub_available {n : ℕ} (f g : (Fin n → ℕ) → ℕ) : + Synthesis interpretation {f, g} {fun x => f x - g x} 1 := by + simpa [interpretation] using Synthesis.gate (I := interpretation) (s := {f, g}) .sub + (fun i => if i.val = 0 then f else g) (fun i => by split <;> simp) + +example (value : ℕ) : + ∃ g ≤ 1, ∃ c : Circuit signature 0 g 1, c.Computes interpretation (fun _ => value) := + (Synthesis.nullary (I := interpretation) (s := inputs 0) (.const value) rfl).exists_circuit + +example (n : ℕ) : + ∃ g ≤ 1, ∃ c : Circuit signature n g 1, + c.Computes interpretation (fun x => ∑ i, x i) := by + have h := Synthesis.gate_of_syntheses (I := interpretation) (.total n) + (fun i x => x i) (fun _ => 0) projection + simpa [interpretation] using h.exists_circuit + +private def product (x : Fin 2 → ℕ) : ℕ := x 0 * x 1 + +private def sharedOutputs (i : Fin 3) (x : Fin 2 → ℕ) : ℕ := + if i = 1 then product x + x 0 else product x + +-- The product is computed once, used by the sum, and selected twice as an output. +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 3, + ∀ x i, c.eval interpretation x i = sharedOutputs i x := by + have hproduct : Synthesis interpretation (inputs 2) {product} 1 := + Synthesis.gate (I := interpretation) .mul (fun i x => x i) (fun i => ⟨i, rfl⟩) + have hkeep : Synthesis interpretation (inputs 2 ∪ {product}) {product} 0 := + Synthesis.of_subset Set.subset_union_right + have hinput : Synthesis interpretation (inputs 2 ∪ {product}) {fun x => x 0} 0 := + (projection 0).mono Set.subset_union_left Set.Subset.rfl le_rfl + have hsum : Synthesis interpretation (inputs 2 ∪ {product}) {fun x => product x + x 0} 1 := by + simpa [interpretation] using hkeep.binary hinput .add + have h := hproduct.comp (hkeep.union hsum) + have hout : Synthesis interpretation (inputs 2) (Set.range sharedOutputs) 2 := + h.mono Set.Subset.rfl (by rintro _ ⟨i, rfl⟩; unfold sharedOutputs; split <;> simp) le_rfl + exact hout.exists_circuit_family + +-- Subtraction is neither commutative nor associative; the list determines the order. +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 1, + c.Computes interpretation (fun x => x 0 - (x 1 - x 0)) := by + have h := Synthesis.foldr (I := interpretation) (· - ·) 1 sub_available + ([0, 1] : List (Fin 2)) (fun i x => x i) (fun _ => 0) + (fun x => x 0) (projection 0) (fun i _ => projection i) + simpa using h.exists_circuit + +-- A finite-set fold may start from an available, nonconstant seed. +example : ∃ g ≤ 2, ∃ c : Circuit signature 2 g 1, + c.Computes interpretation + (fun x => Finset.univ.fold (· + ·) (x 0) (fun i : Fin 2 => x i)) := by + have h := Synthesis.finset_fold (I := interpretation) (· + ·) 1 add_available + (Finset.univ : Finset (Fin 2)) (fun i x => x i) (fun _ => 0) + (fun x => x 0) (projection 0) (fun i _ => projection i) + simpa using h.exists_circuit + +example : ∃ g ≤ 0, ∃ c : Circuit signature 1 g 1, + c.Computes interpretation (fun x => x 0) := by + have h := Synthesis.finset_fold (I := interpretation) (· + ·) 1 add_available + (∅ : Finset (Fin 1)) (fun i x => x i) (fun _ => 0) + (fun x => x 0) (projection 0) (fun i _ => projection i) + simpa using h.exists_circuit + +end CslibTests.Synthesis diff --git a/GOVERNANCE.md b/GOVERNANCE.md index fbe4cce2df..7eeeed33da 100644 --- a/GOVERNANCE.md +++ b/GOVERNANCE.md @@ -45,6 +45,7 @@ Area maintainers are trusted contributors who take ownership of specific areas o - Chris Henson (@chenson2018), Drexel University. Areas: Lambda calculus, metaprogramming. - Kim Morrison (@kim-em), Lean FRO. Areas: Continuous Integration and Deployment (CI/CD) with upstream (Lean, mathlib). - Alexandre Rademaker (@arademaker), Renaissance Philanthropy and Getulio Vargas Foundation. Areas: logic. +- Samuel Schlesinger (@SamuelSchlesinger), Google. Areas: complexity, cryptography, and learning theory. - Sorrachai Yingchareonthawornchai (@sorrachai), ETH Zurich. Areas: algorithms and data structures. ## Reviewers @@ -53,6 +54,6 @@ Reviewers are trusted contributors who provide regular reviewing and technical g - Ching-Tsun Chou (@ctchou). - Christian Reitwiessner (@crei). -- Samuel Schlesinger (@SamuelSchlesinger). - Thomas Waring (@thomaskwaring). - Eric Wieser (@eric-wieser), Google DeepMind. +- Xueying Qin (@XYUnknown), FORM, University of Southern Denmark. diff --git a/PR_PLAN.md b/PR_PLAN.md new file mode 100644 index 0000000000..872c113e00 --- /dev/null +++ b/PR_PLAN.md @@ -0,0 +1,95 @@ +# Turing MultiTape complexity — campaign PR plan + +This branch (`loop/06-tape-transformers`) is the campaign branch: it proves **function +composition** (`computableInTimeAndSpace_comp`) and the **loop combinator** +(`computableInTimeAndSpace_loopFunction`) on top of a reusable machine-layer toolkit. It is also +the PR into `main` that tracks *what is still to do*. + +The work is being split into small, independently reviewable PRs against `main`, one at a time. +After each split PR is finalized, this branch's copies of the files it owns are made byte-identical +to it, so once it lands the campaign diff shows only the remaining work. + +This file is campaign bookkeeping; it is **not** part of any split PR and should never be merged +into `main`. + +## Status + +| PR | Name | State | Branch | +|----|------|-------|--------| +| 1 | transforms-tapes | **finalized** | `pr/transforms-tapes` (off `main`) | +| 2+ | see below | planned | — | + +Sibling PRs already split earlier in the campaign: `loop/03` (AlmostConstant), `loop/04` +(Option encoding), `loop/05` (Id). + +## Files: new vs. modified + +Pre-existing on `main` (campaign only *adds* to them): `Configuration.lean`, `Deterministic.lean`, +`TapeLemmas.lean`. Everything else under `Cslib/Computability/Machines/Turing/MultiTape/` +(`Plumbing/*`, `NormalForms/*`, `Combinators/*`, `Encodings/Option`) is new. + +## Dependency DAG (intra-`MultiTape` imports) + +``` +Configuration (base; +mapState +withState) + └─ Deterministic (+runFrom_eq_of_halt +exists_minimal_halting_time +...) + ├─ TapeLemmas (+space lemmas) + │ └─ Plumbing/TransformsTapes + │ ├─ Plumbing/Sequential (transformsTapes_seq; seq_spec deferred) + │ ├─ Plumbing/Clear + │ ├─ NormalForms/Instrument + │ └─ NormalForms/Sweep + ├─ Plumbing/StepLemmas + │ ├─ Plumbing/ExtendTapes (+TapeLemmas) + │ ├─ Plumbing/OutputToTape (+TransformsTapes) + │ ├─ Plumbing/InputFromTape (+TransformsTapes) + │ ├─ Plumbing/EmitTape (+TransformsTapes) + │ ├─ Plumbing/RewindTape (+TransformsTapes) + │ ├─ Plumbing/Branch (+TransformsTapes) + │ └─ Plumbing/Repeat (+TransformsTapes) + ├─ Plumbing/RewindInput + └─ Combinators/AlmostConstant (sibling PR) ─┐ + └─ Encodings/Option (sibling PR) │ + Combinators/Id (sibling PR) ─┘ + +NormalForms/Tidy <- Instrument, Sweep, RewindInput, Sequential (uses seq_spec) +NormalForms/Adapters <- Tidy, OutputToTape, RewindTape, InputFromTape, EmitTape, ExtendTapes + (uses seq_spec) +Combinators/Comp <- Adapters +Combinators/Ite <- Comp, AlmostConstant, Branch, Sequential, Adapters +Combinators/Loop <- Option, Id, Adapters, Branch, Repeat, Clear, Sequential, TransformsTapes +``` + +## Proposed PR sequence + +Each foundation lemma (in `Configuration`/`Deterministic`/`TapeLemmas`) rides with the PR of its +first user — no standalone "lemmas only" PR. + +| PR | Contents | Depends on | +|----|----------|-----------| +| **1** ✅ | `TapeLemmas` (space lemmas) · `Plumbing/TransformsTapes` · `Plumbing/Sequential` (interface-level `transformsTapes_seq` only) · `Configuration` (`mapState`, `withState`) · `Deterministic` (`runFrom_eq_of_halt`, `exists_minimal_halting_time`) | `main` | +| **2** | `Plumbing/StepLemmas` · `ExtendTapes` · `OutputToTape` · `InputFromTape` (+ their `Config`/`Deterministic` lemmas: `withOutput`, `val_moveInputPos_*`, `inputSymbol_eq_none_of_boundary`) | 1 | +| **3** | `EmitTape` · `RewindTape` · `RewindInput` · `Clear` | 1, 2 | +| **4** | `Branch` · `Repeat` | 1, 2 | +| **5** | `NormalForms/Instrument` · `Sweep` · `Tidy` (+ `Sequential.seq_spec`, `Deterministic.inputPos_runFrom_le`) | 1–4 | +| **6** | `NormalForms/Adapters` (+ `Deterministic.length_encOut_le`, `length_output_runFrom_le`) | 1–5 | +| **7** | `Combinators/Comp` (`computableInTimeAndSpace_comp`) | 6 | +| **8** | `Combinators/Ite` (`cond`/`ite`/`dite`/`match`) | 6, 7, sibling AlmostConstant | +| **9** | `Combinators/Loop` (`computableInTimeAndSpace_loopFunction`) | 6, siblings Option/Id | + +Siblings `AlmostConstant`, `Encodings/Option`, `Id` land via their own PRs (`loop/03`–`05`) and are +prerequisites for PRs 8–9. + +## Notes / deferrals + +- **`seq_spec`** (raw-configuration composition, `Plumbing/Sequential`) is *not* in PR 1. Its users + are `Tidy` and `Adapters`, so it ships with **PR 5** (first user). PR 1 keeps only the + interface-level `transformsTapes_seq`. On this campaign branch `seq_spec` is already present. +- **`withState`** was moved `TransformsTapes` → `Configuration` (it is a special case of + `mapState`). Applied on this branch too. +- **Follow-up (known):** `isOptionEncoding_encOption` (`Encodings/Option`) is still `proof_wanted`, + so `computableInTimeAndSpace_loopFunction` cannot yet be instantiated end-to-end with the + canonical `Option` encoding. Sound conditional result; discharge to make loop usable with it. +- **Policy:** don't build on Sam's PRs (#872, tm-03..06); credit him as author where his design is + used. Use Mathlib naming even where it conflicts with #872. +- Keep every PR building independently with `lake build --wfail` (+ `lake lint`, `lint-style`). diff --git a/lake-manifest.json b/lake-manifest.json index 931a3fb395..c151aba62d 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -5,17 +5,17 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "950d27063f377d5ccd80d3eeedcebe319d3eb821", + "rev": "1cae91f0957ccf8847f22a6239fa0c032a9e28c6", "name": "mathlib", "manifestFile": "lake-manifest.json", - "inputRev": "950d27063f377d5ccd80d3eeedcebe319d3eb821", + "inputRev": "1cae91f0957ccf8847f22a6239fa0c032a9e28c6", "inherited": false, "configFile": "lakefile.lean"}, {"url": "https://github.com/leanprover-community/plausible", "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "d9598f07b1bc701f1e3aae163d2681c1fd978793", + "rev": "e50948299c4dc4a4c21b1c34b6a6a4fddc19f912", "name": "plausible", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -25,7 +25,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "ba67e212be1197b84c1f1f6299488a10a3002713", + "rev": "95e037bfdc31d3916ac615446847fb01960e2719", "name": "LeanSearchClient", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -35,7 +35,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "e6f3c9cd0408a0024ba182319984f6243752cf4d", + "rev": "f8e94c24111148c9ad1b866212a6e1a0fabb5e76", "name": "importGraph", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -45,7 +45,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "a8acbfd87375ff4abe14ce09db5b7664d383bc7f", + "rev": "4c70ac059693669e5756e32a7a94b57ee1e99dc5", "name": "proofwidgets", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -55,7 +55,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "18889deb9e83ea7420ef51c160d6f88552e744e3", + "rev": "75d936c7af167cc93fac0d31237682fc2204591d", "name": "aesop", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -65,7 +65,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "507746ab8f4b643ccdacb2ec4cdb5853fa9f8ab3", + "rev": "786b7acdca7eb4e9c76c5d1d5bd810e7e5c56334", "name": "Qq", "manifestFile": "lake-manifest.json", "inputRev": "master", @@ -75,7 +75,7 @@ "type": "git", "subDir": null, "scope": "leanprover-community", - "rev": "4cac2177c37f5530c4da76aa8e4307f3fc9e4dcb", + "rev": "167242e0621ba382fd6f7b2a7e932ce0811f9ab1", "name": "batteries", "manifestFile": "lake-manifest.json", "inputRev": "main", @@ -85,10 +85,10 @@ "type": "git", "subDir": null, "scope": "leanprover", - "rev": "ab3a82db9fea14cf0fd7f5a2de650f4b534640af", + "rev": "2842b9871b04862f944c032e34052cb9448ccb71", "name": "Cli", "manifestFile": "lake-manifest.json", - "inputRev": "v4.34.0-rc2", + "inputRev": "v4.35.0-rc2", "inherited": true, "configFile": "lakefile.toml"}], "name": "cslib", diff --git a/lakefile.toml b/lakefile.toml index 7e3bbf520f..98e060d7c7 100644 --- a/lakefile.toml +++ b/lakefile.toml @@ -18,7 +18,7 @@ weak.linter.unicodeLinter = false [[require]] name = "mathlib" scope = "leanprover-community" -rev = "950d27063f377d5ccd80d3eeedcebe319d3eb821" +rev = "1cae91f0957ccf8847f22a6239fa0c032a9e28c6" [[lean_lib]] name = "Cslib" diff --git a/lean-toolchain b/lean-toolchain index b814d987e0..acc704ffe6 100644 --- a/lean-toolchain +++ b/lean-toolchain @@ -1 +1 @@ -leanprover/lean4:v4.34.0-rc2 +leanprover/lean4:v4.35.0-rc2 diff --git a/references.bib b/references.bib index 72051ea9c2..afbe3d9b02 100644 --- a/references.bib +++ b/references.bib @@ -255,6 +255,16 @@ @article{ Hennessy1985 bibsource = {dblp computer science bibliography, https://dblp.org} } +@book{Holcombe1982, + title={Algebraic automata theory}, + author={Holcombe, W. M. L.}, + volume={1}, + series={Cambridge Studies in Advanced Mathematics}, + year={1982}, + publisher={Cambridge University Press}, + isbn={0-521-60492-3} +} + @book{ KatzLindell2020, author = {Jonathan Katz and Yehuda Lindell}, @@ -428,6 +438,41 @@ @article{ ShepherdsonSturgis1963 address = {New York, NY, USA} } +@article{Shannon1949, + author = {Claude E. Shannon}, + title = {The Synthesis of Two-Terminal Switching Circuits}, + journal = {Bell System Technical Journal}, + volume = {28}, + number = {1}, + pages = {59--98}, + year = {1949}, + doi = {10.1002/j.1538-7305.1949.tb03624.x}, + url = {https://deeplearning.cs.cmu.edu/F24/document/readings/Shannon49.pdf} +} + +@article{Lupanov1958, + author = {Oleg B. Lupanov}, + title = {On a Method of Circuit Synthesis}, + journal = {Izvestiya Vysshikh Uchebnykh Zavedenii. Radiofizika}, + volume = {1}, + number = {1}, + pages = {120--140}, + year = {1958}, + note = {In Russian}, + url = {https://radiophysics.unn.ru/sites/default/files/papers/1958_1_120.pdf} +} + +@book{Jukna2012, + author = {Stasys Jukna}, + title = {Boolean Function Complexity: Advances and Frontiers}, + series = {Algorithms and Combinatorics}, + volume = {27}, + publisher = {Springer}, + year = {2012}, + doi = {10.1007/978-3-642-24508-4}, + url = {https://web.vu.lt/mif/s.jukna/boolean/index.html} +} + @inproceedings{Valiant1984, author = {Valiant, L. G.}, title = {A Theory of the Learnable},